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

尝试下面的代码。希望它应该工作正常。我尝试了样本数据，它很适合我

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

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

1 个答案: