VBA For 循环填充最后一个条目直到结束

Question

first post and also new to VBA so I apologize for anything that is unclear. I have created a code to generate a daily printout of employees, equipment, and subcontractors. The loop is looking for "S" (subcontractors) each day. There is only one day where "S" is present and there are 4 on that day. The issue is that the loop begins correctly and populates the correct information when it finds "S" and lists the 4 separate subcontractors, but every day before and after that it continues to list the first subcontractor even though no "S" is found on those dates. How can I get it to clear that entry if no other "S" are found? I hope that makes sense and I have included the code. Thank you!

Screesnhot

Sub WriteReport_Click()

Dim EachName(1 To 5000) As Variant
Dim NameHours(1 To 5000) As Variant
Dim NamePhase(1 To 5000) As Variant
Dim EquipHours(1 To 5000) As Variant
Dim EquipPhase(1 To 5000) As Variant
Dim EachDate(1 To 5000) As Date
Dim EachEquip(1 To 5000) As Variant
Dim EachSub(1 To 5000) As Variant
Dim SubAmount(1 To 5000) As Variant
Dim i As Long 'loop through records
Dim k As Integer 'count employees
Dim h As Integer 'count equipment
Dim t As Integer 'count subcontractor
Dim m As Integer 'count dates
Dim j As Integer
Dim x As Integer
Dim lr, s, p, StartBorder, EndBorder As Integer 'keeps row counts Start & Finish
Dim TestString As String

Sheets("Data").Activate

k = 1 'counts EachName
h = 1 'counts EachEquip
t = 1 'counts EachSub
m = 1 'counts dates
lr = 1
p = 0

For i = 1 To Rows.Count
  If Cells(i, 3) = "L" Then
     EachName(1) = Cells(i, 11)
     Exit For
  End If
Next i

For i = 1 To Rows.Count
  If Cells(i, 3) = "E" Then
     EachEquip(1) = Cells(i, 12)
     Exit For
  End If
Next i

For i = 1 To Rows.Count
  If Cells(i, 3) = "S" Then
     EachSub(1) = Cells(i, 9)
     Exit For
  End If
Next i

NameHours(1) = 0
EquipHours(1) = 0
EachDate(1) = Cells(1, 1)
SubAmount(1) = 0

Dim LastRow As Integer


For i = 1 To 5000

    If EachDate(m) <> Cells(i, 1) Then
       m = m + 1 'setting array for next new date
       EachDate(m) = Cells(i, 1)
       lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
       StartBorder = lr
       Sheets("Report").Cells(lr, 1) = Format(EachDate(m - 1), "mm/dd/yy") 'prints date
       Sheets("Report").Cells(lr, 1).Interior.ColorIndex = 4 'highlights date
       
       For j = 1 To k 'prints employees, hours and phase
         Sheets("Report").Cells((lr + j), 1) = EachName(j)
         Sheets("Report").Cells((lr + j), 2) = NameHours(j)
         Sheets("Report").Cells((lr + j), 4) = NamePhase(j)
         Sheets("Report").Cells((lr + j), 5).Formula = _
         "=IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",Employee,2,FALSE),"""")"
         
       Next j
       k = 1
       lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
       
       For s = i To 5000 'getting first employee for next date
          If Cells(s, 1) = EachDate(m) And Cells(s, 3) = "L" Then
             EachName(1) = Cells(s, 11)
             Exit For
          End If
       Next s
       
       Erase NameHours 'clearing manhours for next date
       
       For j = 1 To h
         Sheets("Report").Cells((lr + j), 1) = Trim(EachEquip(j))
         Sheets("Report").Cells((lr + j), 3) = EquipHours(j)
         Sheets("Report").Cells((lr + j), 4) = EquipPhase(j)
         Sheets("Report").Cells((lr + j), 5).Formula = _
         "=LEFT(IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",EquipList,2,FALSE),""""),20)"
       Next j
     
       h = 1
       For s = i To 5000 'getting first equipment for next date
          If Cells(s, 1) = EachDate(m) And Cells(s, 3) = "E" Then
             EachEquip(1) = Cells(s, 12)
             Exit For
          End If
       Next s
       Erase EquipHours ' clearing equipment hours for next date
       
       lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
        
       For x = 1 To t
         Sheets("Report").Cells((lr + x), 1) = EachSub(x)
         Sheets("Report").Cells((lr + x), 3) = SubAmount(x)
       Next x
       
       For x = i To 5000 'getting subcontractor for next date
          If Cells(x, 1) = EachSub(m) And Cells(x, 3) = "S" Then
             EachSub(1) = " "
             Exit For
          End If
       Next x
       
       EndBorder = lr + x
       t = 1
       
        With Worksheets("Report") 'draws borders
       .Range(.Cells(StartBorder, 1), .Cells(EndBorder, 8)).BorderAround ColorIndex:=1, Weight:=xlThick
       End With
            
    End If
    
    Select Case Cells(i, 3).Value
       Case "L"
          If Cells(i, 11) = EachName(k) Then
             If Cells(i, 7) = 0 Then
                p = p + 1 'adding up per diem
             End If
             NamePhase(k) = Cells(i, 2)
             NameHours(k) = NameHours(k) + Cells(i, 7)
          Else
             k = k + 1
             EachName(k) = Cells(i, 11)
             NamePhase(k) = Cells(i, 2)
               If Cells(i, 7) = 0 Then
                  p = p + 1
               End If
             NameHours(k) = NameHours(k) + Cells(i, 7)
          End If
          
        Case "E"
          If Cells(i, 12) = EachEquip(h) Then
             EquipPhase(h) = Cells(i, 2)
             EquipHours(h) = EquipHours(h) + Cells(i, 7)
          Else
             h = h + 1
             EachEquip(h) = Cells(i, 12)
             EquipPhase(h) = Cells(i, 2)
             EquipHours(h) = EquipHours(h) + Cells(i, 7)
          End If
          
          Case "S"
          If Cells(i, 9) = EachSub(t) Then
             EachSub(t) = Cells(i, 9)
             SubAmount(t) = SubAmount(t) + Cells(i, 8)
          Else
             t = t + 1
             EachSub(t) = Cells(i, 9)
             SubAmount(t) = SubAmount(t) + Cells(i, 8)
          End If
          
    End Select
Next i
MsgBox "Report Completed !!!"
End Sub

Answer 1

You will find your code easier to debug/maintain if you separate the collection of the data and the report generation into 2 discrete steps, preferably in subroutines. For example

Option Explicit

Dim EachName(0 To 5000, 1 To 3) As Variant '1=name 2=hours 3=phase
Dim EachEquip(0 To 5000, 1 To 3) As Variant '1=name 2=hrs 3=phase
Dim EachSub(0 To 5000, 1 To 2) As Variant ' 1=name 2=amount

Dim k As Long 'count employees
Dim h As Long 'count equipment
Dim t As Long 'count subcontractor

Sub WriteReport_Click()

    ' specify book and sheets to process
    Dim wb As Workbook, wsData As Worksheet, wsRep As Worksheet
    Set wb = ThisWorkbook  ' or ActiveWorkBook
       
    ' determine extent of data
    Dim LastRow As Long, iRow As Long
    Set wsData = wb.Sheets("Data")
    LastRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' clear report sheet
    Set wsRep = wb.Sheets("Report")
    wsRep.Cells.Clear
    
    ' scan data for first date
    Dim RepDate As Date
    RepDate = wsData.Cells(1, 1)
    Call GetData(RepDate, wsData)

    ' scan data for more dates
    For iRow = 1 To LastRow
    
        If wsData.Cells(iRow, 1) <> RepDate Then
           ' report existing date
           Call ReportData(RepDate, wsRep)
           
           ' get data for new date
           RepDate = wsData.Cells(iRow, 1)
           Call GetData(RepDate, wsData)
           
        End If
    Next
    ' report last date
    Call ReportData(RepDate, wsRep)
    
    'end
    wsRep.Columns("A:E").AutoFit
    MsgBox "Report Completed", vbInformation, LastRow & " rows scanned"
End Sub

Sub ReportData(d As Date, ws As Worksheet)
    Debug.Print "ReportData", d
    
    Dim lr As Long, StartBorder As Long, EndBorder As Long, j As Long
   
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
    StartBorder = lr
    ws.Cells(lr, 1) = Format(d, "mm/dd/yy") 'prints date
    ws.Cells(lr, 1).Interior.ColorIndex = 4 'highlights date
       
    'prints employees, hours and phase
    For j = 1 To k
        ws.Cells((lr + j), 1) = EachName(j, 1) 'empoyee name
        ws.Cells((lr + j), 2) = EachName(j, 2) 'hrs
        ws.Cells((lr + j), 4) = EachName(j, 3) 'phase
        ws.Cells((lr + j), 5).Formula = _
         "=IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",Employee,2,FALSE),"""")"
    Next j
       
    ' report equipment
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
    For j = 1 To h
        ws.Cells((lr + j), 1) = EachEquip(j, 1) 'equip name
        ws.Cells((lr + j), 3) = EachEquip(j, 2) 'hours
        ws.Cells((lr + j), 4) = EachEquip(j, 3) 'phase
        ws.Cells((lr + j), 5).Formula = _
         "=LEFT(IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",EquipList,2,FALSE),""""),20)"
    Next j
       
    ' report sub contractors
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
    For j = 1 To t
        ws.Cells((lr + j), 1) = EachSub(j, 1) 'sub name
        ws.Cells((lr + j), 3) = EachSub(j, 2) 'amount
    Next j
       
     ' draws borders
    EndBorder = ws.Cells(Rows.Count, 1).End(xlUp).Row
    ws.Range(ws.Cells(StartBorder, 1), ws.Cells(EndBorder, 8)) _
            .BorderAround ColorIndex:=1, Weight:=xlThick
         
End Sub

Sub GetData(d As Date, ws As Worksheet)
    Debug.Print "GetData", d

    Dim LastRow As Long, i As Long
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' clear global arrays
    Erase EachName
    Erase EachEquip
    Erase EachSub
    k = 0: h = 0: t = 0
       
    For i = 1 To LastRow
        If ws.Cells(i, 1) = d Then
          
            Select Case ws.Cells(i, 3)
                Case "L" ' Employee
                    If ws.Cells(i, 11) <> EachName(k, 1) Then
                        k = k + 1
                    End If
                    EachName(k, 1) = ws.Cells(i, 11)
                    EachName(k, 2) = ws.Cells(i, 7) + EachName(k, 2)  ' hours
                    EachName(k, 3) = ws.Cells(i, 2) ' phase
                 
                Case "E" ' Equipment
                    If ws.Cells(i, 12) <> EachEquip(h, 1) Then
                        h = h + 1
                    End If
                    EachEquip(h, 1) = Trim(ws.Cells(i, 12)) ' equip name
                    EachEquip(h, 2) = ws.Cells(i, 7) + EachEquip(h, 2) ' hours
                    EachEquip(h, 3) = ws.Cells(i, 2) ' phase
                
                Case "S" ' Subcontractor
                    If ws.Cells(i, 9) <> EachSub(t, 1) Then
                        t = t + 1
                    End If
                    EachSub(t, 1) = ws.Cells(i, 9) ' sub name
                    EachSub(t, 2) = ws.Cells(i, 8) + EachSub(t, 2) ' amount
                    
                Case Else
                    MsgBox "Unknown code at row " & i, vbExclamation
                End Select
        End If
    Next

End Sub