Использование массива для создания отчетов с копированием из источника данных с использованием уникального списка для создания отдельных отчетов

Question

Я использую код ниже, который я нашел на этом сайте некоторое время назад.Код выполняется так, как и должно быть для каждого ввода.

ws1 - это уникальный список центров затрат. Ws2 - это длинный длинный перечень данных затрат по центрам затрат.

Что я хочу, чтобы этот кодсделать, найти все затраты, связанные с первым кодом на ws1 из ws2, вставить их на третий лист (шаблон), затем у меня есть код, который превращает этот лист в отчет для этого МВЗ, а затем очищает его содержимое.

Затем я хочу, чтобы код продолжился, и нашел их все для следующего кода на ws2, вставил на третий лист, чтобы я мог создать отчет и т. Д. И т. Д. И т. П.

на ws2 имеется 65000 записейсвязанный с одним из 26 МВЗ центров затрат ws1.

 Option Explicit     

 Sub createReports()

   Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
   Dim i As Long, j As Long

    ws1 = ActiveWorkbook.Sheets("UniqueList").UsedRange
    ws2 = ActiveWorkbook.Sheets("Data Sheet").UsedRange

 ReDim ws3(11, 0)
      For i = 1 To UBound(ws1)
            For j = 1 To UBound(ws2)
                If Trim$(ws1(i, 1)) = Trim$(ws2(j, 1)) Then
                   ReDim Preserve ws3(11, Count)
                      ws3(0, Count) = ws2(j, 1)
                      ws3(1, Count) = ws2(j, 2)
                      ws3(2, Count) = ws2(j, 3)
                      ws3(3, Count) = ws2(j, 4)
                      ws3(4, Count) = ws2(j, 5)
                      ws3(5, Count) = ws2(j, 6)
                      ws3(6, Count) = ws2(j, 7)
                      ws3(7, Count) = ws2(j, 8)
                      ws3(8, Count) = ws2(j, 9)
                      ws3(9, Count) = ws2(j, 10)
                      ws3(10, Count) = ws2(j, 11)
                     Count = Count + 1

               End If

         Next j

        Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("Template").[A2])
        Call createWrkBooks
        Call clearContents

   Next i



 Set ws1 = Nothing
 Set ws2 = Nothing

 End Sub

, в настоящее время код выполняется, но копирует все данные из ws2, но группирует строки в порядке центров затрат.

Я хотел бы создать 26 отдельных отчетов, сначала скопированных в шаблон, которые мои другие коды будут сохранять в виде рабочей книги, а затем очищать содержимое.готов к заселению.

Answer 1

Из массива в транспонирование массива

Вы не объявили count.Используйте Option Explicit, чтобы избежать этого.

Option Explicit

0-версия

Эта версия должна работать прямо сейчас.

Sub createReports0B()

    Const cRows As Long = 10

    Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
    Dim i As Long, j As Long, k As Long
    Dim count As Long

    ws1 = ActiveWorkbook.Sheets("UniqueList").UsedRange
    ws2 = ActiveWorkbook.Sheets("Data Sheet").UsedRange

    For i = 1 To UBound(ws1)
        count = 0
        ReDim ws3(cRows, count)
        For j = 1 To UBound(ws2)
            If Trim$(ws1(i, 1)) = Trim$(ws2(j, 1)) Then
                ReDim Preserve ws3(cRows, count)
                For k = 0 To cRows
                    ws3(k, count) = ws2(j, k + 1)
                Next k
                count = count + 1
            End If
        Next j

        Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("Template").[A2])
        Call createWrkBooks
        Call ClearContents

    Next i

End Sub

1-версия

Я бы пошел с массивом на основе 1, потому что он может быть быстрее передан в диапазон (без зацикливания).

Sub createReports1B()

    Const cRows As Long = 11

    Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
    Dim i As Long, j As Long, k As Long
    Dim count As Long

    ws1 = ActiveWorkbook.Sheets("UniqueList").UsedRange
    ws2 = ActiveWorkbook.Sheets("Data Sheet").UsedRange

    For i = 1 To UBound(ws1)
        count = 1
        ReDim ws3(1 To cRows, 1 To count)
        For j = 1 To UBound(ws2)
            If Trim$(ws1(i, 1)) = Trim$(ws2(j, 1)) Then
                ReDim Preserve ws3(1 To cRows, 1 To count)
                For k = 1 To cRows
                    ws3(k, count) = ws2(j, k)
                Next k
                count = count + 1
            End If
        Next j

        ' You have to change here because ws3 is a 1B 2D array.
        Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("Template").[A2])
        Call createWrkBooks
        Call ClearContents

    Next i

End Sub

Answer 2

Следующее должно работать.Вам просто нужно заново инициализировать ваши Count и ws3 для каждого i.В противном случае вы добавляете свои новые данные к старым.

're-initialize for the next i
ReDim ws3(11, 0) 'needs to be inside the For i loop
Count = 0

---

Option Explicit

Sub createReports()
    Dim ws1 As Variant, ws2 As Variant, ws3 As Variant
    Dim i As Long, j As Long

    ws1 = ActiveWorkbook.Sheets("UniqueList").UsedRange
    ws2 = ActiveWorkbook.Sheets("Data Sheet").UsedRange

    For i = 1 To UBound(ws1)
        're-initialize for the next i
        ReDim ws3(11, 0) 'needs to be inside the For i loop
        Count = 0

        'collect everything for the current i
        For j = 1 To UBound(ws2)
            If Trim$(ws1(i, 1)) = Trim$(ws2(j, 1)) Then
                ReDim Preserve ws3(11, Count)
                ws3(0, Count) = ws2(j, 1)
                ws3(1, Count) = ws2(j, 2)
                ws3(2, Count) = ws2(j, 3)
                ws3(3, Count) = ws2(j, 4)
                ws3(4, Count) = ws2(j, 5)
                ws3(5, Count) = ws2(j, 6)
                ws3(6, Count) = ws2(j, 7)
                ws3(7, Count) = ws2(j, 8)
                ws3(8, Count) = ws2(j, 9)
                ws3(9, Count) = ws2(j, 10)
                ws3(10, Count) = ws2(j, 11)
                Count = Count + 1
            End If
        Next j

        'save the current i colleted data
        Call PasteArray(transposeArray(ws3), ActiveWorkbook.Sheets("Template").[A2])
        Call createWrkBooks
        Call ClearContents
    Next i

    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub