AW: neuer Code
17.04.2017 08:07:44
Sepp
Hallo Frank,
die Rückfahrten hab ich gar nicht bedacht ;-)
Mit diesem Code werden auch diese berücksichtigt.
Sub check2()
Dim objSht As Worksheet, objChk As Worksheet, objRides As Worksheet
Dim lngNext As Long, lngI As Long, lngLast As Long, lngC As Long, lngE As Long
Dim bolDone As Boolean
Set objChk = Sheets("Check")
Set objRides = Sheets("Dauerfahrten")
With objRides
lngE = Application.Max(5, .Cells(.Rows.Count, 2).End(xlUp).Row)
End With
objChk.Range("A2:E1000").ClearContents
lngNext = 1
For Each objSht In ThisWorkbook.Worksheets
If IsDate(objSht.Name) Then
With objSht
lngLast = Application.Max(5, .Cells(Rows.Count, 2).End(xlUp).Row)
For lngI = 5 To lngLast
bolDone = False
If .Cells(lngI, 2) <> "" And .Cells(lngI, 3) <> "" Then
For lngC = 5 To lngE
If objRides.Cells(lngC, 2) <> "" And objRides.Cells(lngC, 3) <> "" Then
If ((.Cells(lngI, 2) = objRides.Cells(lngC, 2) And .Cells(lngI, 3) = objRides.Cells(lngC, 3)) Or _
(.Cells(lngI, 2) = objRides.Cells(lngC, 3) And .Cells(lngI, 3) = objRides.Cells(lngC, 2))) And _
.Cells(lngI, 4) <> objRides.Cells(lngC, 4) Then
lngNext = lngNext + 1
objChk.Cells(lngNext, 1) = .Cells(1, 2)
objChk.Hyperlinks.Add _
Anchor:=objChk.Cells(lngNext, 2), _
Address:="", _
SubAddress:="'" & .Name & "'!" & .Cells(lngI, 2).Address, _
TextToDisplay:=Mid(.Cells(lngI, 2), InStr(1, .Cells(lngI, 2), Chr(10)) + 1)
objChk.Cells(lngNext, 3) = Mid(.Cells(lngI, 3), InStr(1, .Cells(lngI, 3), Chr(10)) + 1)
objChk.Cells(lngNext, 4) = objRides.Cells(lngC, 4)
objChk.Cells(lngNext, 5) = .Cells(lngI, 4)
Exit For
End If
End If
Next
End If
Next
End With
End If
Next
End Sub
Zum Färben der aktiven Zeile nutze diesen Code (kommt in das Modul "Diese Arbeitsmappe")
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
With Sh
If IsDate(.Name) Then
.Cells.Interior.ColorIndex = xlNone
If Target.Column < 5 Then
.Range(.Cells(Target.Row, 1), .Cells(Target.Row, 4)).Interior.ColorIndex = 6
End If
End If
End With
End Sub
Gruß Sepp