VBA-Skript Schleife durch Spalte B nach Spalte A Wert

Question

Ich habe Probleme beim Durchschleifen von Daten in einem Excel, Kann mir jemand helfen.

Ich habe zwei Spalten in meinem Excel-Blatt Name und Reisedatum.

Name  Date of travel 
Ron  2/7/2016 17:58 
Tom  2/7/2016 19:55 
Joy  3/7/2016 5:58 
Joy  3/7/2016 20:13 
Joy  3/7/2016 20:46 
Jerry  3/7/2016 22:24 
Mathew  4/7/2016 4:18 
Ron  4/7/2016 5:59 
Jerry  4/7/2016 22:23 

Ich möchte 3 Regeln für diese Tabelle anwenden.

- Each member(name) should have 2 or less entries per day 
    Action: Highlight all other entries. 
- All trips should be before 0800 or after 1800. 
    ACTION: Highlight all other entries. 
-No trips should be there from Sat 0800 to Sun 2400. 
    ACTION: Highlight all such entries. 

Bitte helfen Sie mir.

Answer 1

Versuchen Sie unter code.Hope sollte es gut funktionieren. Ich probierte es mit Beispieldaten, es funktionierte gut von mir

Option Explicit 
Public cellsRange As Range 
Public myWorksheet As Worksheet 

Sub ApplyRules() 

'Replace "Sheet6" with your sheet name 
Set myWorksheet = Worksheets("Sheet6") 
Set cellsRange = myWorksheet.UsedRange 
ApplyRule1 
ApplyRule2_Rule3 
End Sub 

Public Function ApplyRule2_Rule3() 
    Dim dayOfTravel As Variant 
    Dim timeOfTrave As Variant 
    Dim cell As Variant 
    Dim satCutOff As Variant 
    Dim sunCutOff As Variant 
    Dim startCutOff As Variant 
    Dim endCutOff As Variant 

    satCutOff = Format("08:00", "Hh:mm") 
    startCutOff = Format("08:00", "Hh:mm") 
    endCutOff = Format("18:00", "Hh:mm") 

    For Each cell In cellsRange.Columns(2).Cells 
     If (cell.Value <> "Date of travel") Then 
      dayOfTravel = Weekday(CDate(cell.Value), vbSunday) 
      'Rule3: Sunday check 
      If (dayOfTravel = 1) Then 'Sunday Trip 
       cell.Interior.Color = vbRed 'Red For Rule3 
       cell.Offset(0, -1).Interior.Color = vbRed 
      'Rule3: Saturday check 
      ElseIf (dayOfTravel = 7) Then 
       If (Format(cell.Value, "Hh:mm") > satCutOff) Then 
        cell.Interior.Color = vbRed 
        cell.Offset(0, -1).Interior.Color = vbRed 
       End If 
      'Rule2 check 
      Else 
       'Check if time is after "08:00" and before "18:00" 
       If (Format(cell.Value, "Hh:mm") > startCutOff And Format(cell.Value, "Hh:mm") < endCutOff) Then 
        cell.Interior.Color = vbYellow 
        cell.Offset(0, -1).Interior.Color = vbYellow 
       End If 
      End If 
     End If 
    Next cell 
End Function 


Public Function ApplyRule1() 

    Dim uniqueNames As Collection 
    Dim uniqueName As Variant 
    Dim currentDayCount As Integer 
    Dim currentDay As Variant 
    Dim cell As Variant 
    Dim traveldate As Variant 

    Set uniqueNames = New Collection 
    'Capturing all uniques names 
    On Error Resume Next 
    For Each cell In cellsRange.Columns(1).Cells 
     If (Trim(cell.Value) <> "Name" And Trim(cell.Value) <> "") Then 
      uniqueNames.Add Trim(cell.Value), Trim(cell.Value) 
     End If 
    Next cell 

    For Each uniqueName In uniqueNames 
     For Each cell In cellsRange.Columns(1).Cells 
      If (uniqueName = Trim(cell.Value)) Then 
       currentDayCount = 0 
       currentDay = DateValue(Trim(cell.Offset(0, 1).Value)) 
       For Each traveldate In cellsRange.Columns(2).Cells 
       If (Trim(traveldate.Value) <> "Date of travel") Then 
        If ((currentDay = DateValue(Trim(traveldate.Value))) And uniqueName = Trim(traveldate.Offset(0, -1))) Then 
         currentDayCount = currentDayCount + 1 
         If (currentDayCount > 2) Then 
          traveldate.Offset(0, -1).Interior.Color = vbGreen 
          traveldate.Interior.Color = vbGreen 
         End If 
        End If 
       End If 


       Next traveldate 
      End If 
     Next cell 
    Next uniqueName 

End Function