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列值

回答

相關問題