VBA For 循環填充最后一個條目直到結束

Question

第一篇文章，也是 VBA 的新手，所以對於任何不清楚的地方，我深表歉意。 我創建了一個代碼來生成員工、設備和分包商的每日打印輸出。 循環每天都在尋找“S”（分包商）。 “S”只有一天出現，那一天有 4 個。 問題是循環正確開始並在找到“S”並列出 4 個單獨的分包商時填充正確的信息，但在此之前和之后的每一天，即使在那些上沒有找到“S”，它也會繼續列出第一個分包商日期。 如果沒有找到其他“S”，我如何才能清除該條目？ 我希望這是有道理的，我已經包含了代碼。 謝謝！

屏幕截圖

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

如果您將數據的收集和報告生成分成 2 個離散的步驟，最好是在子程序中，您會發現您的代碼更容易調試/維護。 例如

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