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

我无法循环查看excel中的数据，任何人都可以帮助我。vba脚本根据列A循环遍历B列值

我有两列在我的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.

请帮帮我。

来源

2016-08-19 Naveen

你能分享一下你到目前为止试过的代码，以及你的哪部分代码不工作？ – Siva

谢谢你的回应siva，我对vba很新。对于第一条规则，我只是将旅行日期中的时间部分设为00，如果在B列中发现重复的日期，我可以将3列打印为重复（这还不够，因为同一日期发生两次是可以接受的）。所以我完全困惑。 – Naveen

我已发布并回答。你可以试试。如果遇到问题，请告诉我。请根据您的需要修改代码（表格名称，范围..） – Siva

尝试下面的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

来源

2016-08-19 13:55:03 Siva

非常感谢Siva。非常感谢您。它正在处理我的数据。我做了小修改（在第一条规则中，2个条目是可以接受的，当单个名称有3个条目时需要突出显示）。我通过改变条件来修正这个问题。谢谢你。我正在检查其他规则。 – Naveen

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

回答

相关问题