Dynami c для заполнения другого цикла таблицы

Question

Я пытаюсь заполнить форму из другой таблицы. У меня есть идентификатор (formNumber). Цель l oop - найти все строки в таблице с одинаковым 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

Проблема с вашим кодом в то время как l oop lrCurrent не меняется. после x = x +1 вам нужно установить

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

Также необходимо защитить от пробега после конца таблицы, добавив еще одно условие

And x <= loTable1.ListRows.Count 

в строку Do While в начало.

Вот пример с меньшим количеством переменных с использованием .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