vba脚本根据列A循环遍历B列值

Question

我无法循环查看excel中的数据， 任何人都可以帮助我。

我有两列在我的Excel表名和旅行日期。

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 

我想为此表应用3个规则。

- 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. 

请帮帮我。

Answer 1

尝试下面的code.Hope它应该工作正常。我试着用样品数据，它工作得很好

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