excel - VBA For循环填充最后一个条目直到结束
问题描述
第一篇文章,也是 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
解决方案
如果您将数据的收集和报告生成分成 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
推荐阅读
- bash - Bash 排序未正确按时间排序
- karate - 如何为空手道 UI 自动化中运行的所有场景仅自定义一次 chrome 驱动程序调用
- javascript - 获取多个 url 然后相应地设置状态 React Native
- intellij-idea - 如何使用终端从 ubuntu 20.04 LTS 卸载任何软件?
- python - Python 如何将当前目录添加到 sys.path
- javascript - Vue3 在子组件中使用 v-model
- java - Function with .random() method malfunctions after a few runs for no apparent reason
- node.js - when I install jupyterlab-kite build error
- swift - Problems with StackView after using a function the second time
- typescript - 为什么我在运行时收到 Typescript 编译错误?