动态以填充另一个表循环

Question

我正在尝试从另一个表中填充表单。我有一个标识符(表单编号(。循环的目的是查找表中具有相同 formNumber 的所有行，然后在表单中列出详细信息。

遇到的问题是在使用startTableRow、startSubdesc1、startSubdesc2、startRemark的字段中。我不知道他们什么时候都在重复已经输入的相同值。一个项目只能出现一次。

Dim wsCurrent As Worksheet, _
loTable1 As ListObject, _
lcColumns As ListColumns, _
lrCurrent As ListRow
Set wsCurrent = Worksheets("Expenses")
Set loTable1 = wsCurrent.ListObjects("Expenses")
Set lcColumns = loTable1.ListColumns
'Loop through and find new entries which haven't been form'd yet
For x = 1 To loTable1.ListRows.Count
Set lrCurrent = loTable1.ListRows(x)
If lrCurrent.Range(1, lcColumns("form sent?").Index) = "" And _
lrCurrent.Range(1, lcColumns("form #").Index) <> "" Then
formNumber = lrCurrent.Range(1, lcColumns("form #").Index).Value
'Set first lines on the form
Worksheets("form").Cells(10, 10).Value = formNumber
'Loop through the Expense sheet and as long as the form number doesn't _
'change, write it to the table on the form
startTableRow = 20
startSubdesc1 = 21
startSubdesc2 = 22
startRemark = 54
Do While lrCurrent.Range(1, lcColumns("form #").Index).Value = formNumber
expensesDate = lrCurrent.Range(1, lcColumns("Date").Index).Value
expensesItem = lrCurrent.Range(1, lcColumns("Description").Index).Value
expensesSubdesc1 = lrCurrent.Range(1, lcColumns("Sub-description 1").Index).Value
expensesSubdesc2 = lrCurrent.Range(1, lcColumns("Sub-description 2").Index).Value
expensesRemarks = lrCurrent.Range(1, lcColumns("Remarks").Index).Value
**Worksheets("form").Cells(startTableRow, 5) = expensesItem
Worksheets("form").Cells(startSubdesc1, 5) = expensesSubdesc1
Worksheets("form").Cells(startSubdesc2, 5) = expensesSubdesc2
Worksheets("form").Cells(startRemark, 3) = expensesRemarks
Worksheets("form").Cells(12, 10) = expensesDate**
lrCurrent.Range(1, lcColumns("form sent?").Index).Value = "Yes"
x = x + 1
startTableRow = startTableRow + 3
startSubdesc1 = startSubdesc1 + 3
startSubdesc2 = startSubdesc2 + 3
startRemark = startRemark + 1
Loop
'Need to subtract one from x to loop through the row again
x = x - 1
'Clear data in table on form
For t = 20 To 45
Worksheets("form").Cells(t, 3).Value = ""
Worksheets("form").Cells(t, 5).Value = ""
Next t
'Clear data in REMARK on form
For r = 54 To 57
Worksheets("form").Cells(r, 3).Value = ""
Next r
End If
Next x
End Sub
End Sub

Answer 1

您的代码问题在于 while 循环中，lrCurrent 不会改变。 在 x = x +1 之后，您需要设置

lrCurrent = loTable1.ListRows(x) IF x <= loTable1.ListRows.Count

然后还需要通过添加另一个条件来防止跑过表的末尾

And x <= loTable1.ListRows.Count 

到开头的"边做边"行。

下面是使用 .offset 使用较少变量的示例

Sub FillForm()
Dim wb As Workbook, ws As Worksheet, wsForm As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Expenses")
Set wsForm = wb.Sheets("form")
Dim tbl As ListObject
Set tbl = ws.ListObjects("Expenses")
' create look up for column names
Dim ColNum As New Collection
Dim cell As Range, ix As Integer
For Each cell In tbl.HeaderRowRange
ix = ix + 1
ColNum.add ix, cell.Value
Debug.Print cell.Value
Next
' scan table for not sent items
Dim sFormNo As String, rec As Range
Dim iCount As Integer ' count of lnes with same form no
Dim bSearch As Boolean, iSearch As Integer
Dim iRow As Integer
bSearch = False ' search for matching form no
With tbl
For iRow = 1 To .ListRows.Count
Set rec = .ListRows(iRow).Range
If rec(ColNum("form #")) <> "" _
And rec(ColNum("form sent?")) = "" Then
sFormNo = rec(1)
wsForm.Range("J10") = rec(ColNum("form #"))
wsForm.Range("J12") = rec(ColNum("Date"))
bSearch = True
End If
' search rest of table for more records
If bSearch Then
'Clear data in table on form
'wsForm.Range("C20:C45").ClearContents ' required ?
wsForm.Range("E20:C45").ClearContents
wsForm.Range("C54:C57").ClearContents
iCount = 0
' search from existing row down to end
For iSearch = iRow To .ListRows.Count
Set rec = .ListRows(iSearch).Range
' check match
If rec(ColNum("form #")) = sFormNo _
And rec(ColNum("form sent?")) = "" Then
' fill in form
With wsForm.Range("E20").Offset(3 * iCount, 0)
.Offset(0, 0) = rec(ColNum("Description"))
.Offset(1, 0) = rec(ColNum("Sub-description 1"))
.Offset(2, 0) = rec(ColNum("Sub-Description 2"))
End With
wsForm.Range("C54").Offset(iCount, 0) = rec(ColNum("Remarks"))
' update form sent column
rec(ColNum("form sent?")) = "Yes"
iCount = iCount + 1
Debug.Print "Search for " & sFormNo, rec(ColNum("form #")), iCount, iSearch
End If
Next
wsForm.Activate
wsForm.Range("A20").Select
MsgBox iCount & " lines added", vbInformation, "Completed " & sFormNo
bSearch = False
End If
Next
End With
MsgBox "Ended", vbInformation
End Sub