Excel VBA для копирования Для каждой строки в таблице индивидуально

Question

Я теперь понял, что мой оригинальный организационный метод не подходит, поэтому я хочу добавить всю информацию в новый рабочий лист с именем ("RAW")

Я пытаюсь создать Do L oop на основе количества строк таблицы. Здесь я зацикливаюсь на одном "theFILE.xlsm", который открывает книги по одной. Когда рабочая книга открыта, я хочу скопировать

Вот что я хочу сделать; Откройте рабочую книгу (sFile), подсчитайте databodyrange.count в Table2, присвойте счет переменной с именем BodyCount, скопируйте и вставьте нужную строку, L oop для количества раз BodyCount

Каждая книга, которая будет открыта, имеет Таблица 2, но ни одна из таблиц не заполнена, поэтому я не могу полагаться, если ячейка <> "", как я делал с первым Do Хотя L oop.

Как мне создать al oop копировать по 1 строке за раз в зависимости от количества строк в таблице.

Вот что

Sub every_one() ''compile everything into 1 list

''''DIMMENSIONS
Application.ScreenUpdating = False

Dim SourceRow As Long
Dim sFile As String
Dim wb As Workbook
Dim FileName1 As String
Dim FileName2 As String
Dim wksSource As Worksheet
Const scWkbSourceName As String = "theFILE.xlsm"

Set wkbSource = Workbooks(scWkbSourceName)
Set wksSource = wkbSource.Sheets("Sheet1")

Const wsOriginalBook As String = "theFILE.xlsm"
Const sPath As String = "U:\theFILES\" 

SourceRow = 5
DestinationColumn = 2
FirstDestinationRow = 1
SecondDestinationRow = 41

''ENSURE SELECT SOURCE SHEET
Sheets("Sheet1").Select

Do While Cells(SourceRow, "C").Value <> ""

    FileName1 = wksSource.Range("A" & SourceRow).Value
    FileName2 = wksSource.Range("L" & SourceRow).Value

    sFile = sPath & FileName1 & "\" & FileName2 & ".xlsm"

    ''OPEN FILE
    Set wb = Workbooks.Open(sFile)

''insert CODE TO LOOP

    ''DECLARE TABLE
    Dim tbl As ListObject
    Dim BodyCount As Long
    Dim StartingTablePosition As Long

    Set tbl = ActiveSheet.ListObjects("Table2")

    'start FOR, LOOP
    BodyCount = ActiveSheet.ListObjects("Table2").DataBodyRange.Rows.Count
    Dim WorkingRow As Long
    WorkingRow = 20

    For i = WorkingRow to WorkingRow + BodyCount Step 1

        'COPY "SourceRow" from "theFILE.xlsm"
    Windows("theFILE.xlsm").Activate
    Rows(SourceRow).Copy
        'PASTE to Compile Sheet, next available column & TRANSPOSE row into column
    Sheets("RAW").Cells.Item(FirstDestinationRow, DestinationColumn).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True 

        'COPY ROW from "sFile" Table2
    wb.Activate
    Rows(WorkingRow).Copy
    Application.CutCopyMode = False
        'PASTE to Compile sheet, TRANSPOSE row into column
    Windows("theFILE 1.1.xlsm").Activate
    ActiveSheet.Cells.Item(SecondDestinationRow, DestinationColumn).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    DestinationColumn = DestinationColumn + 1

    Next i

''End custom code for desired loop operation

''CLOSE WORKBOOK W/O BEFORE SAVE
wb.Activate
Application.EnableEvents = False
ActiveWorkbook.Save
Application.EnableEvents = True
ActiveWorkbook.Close savechanges:=False

Windows("theFILE.xlsm").Activate
Sheets("Sheet1").Select

''GO TO NEXT .xlsm FILE
SourceRow = SourceRow + 1

Loop

End Sub

Я новичок в For ... Next Loops. Будем весьма благодарны за любые советы, подсказки и подсказки.

Вот несколько картинок,

Answer 1

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

Мой код предполагает:

• У вас есть таблица Excel в Sheet1 (где имена файлов) Я назвал его BaseTable
• Вы выполняете макрос в книге, в которой есть эта таблица
• Ваш целевой лист "RAW" находится в той же книге где вы запускаете макрос
• Внешние рабочие книги имеют Table2 на первом листе

Предложения:

• Создайте backup своих файлов и данных, прежде чем пытаться использовать этот код
• Выполните код, нажимая клавишу F8, и настройте его в соответствии со своими потребностями
• Просмотр кода:
  • Старайтесь избегать использования select и activate см. Этот ответ
  • Попробуйте отделить входные данные от других операторов (назначьте их variables)
  • Indent Ваш код ( Этот плагин имеет отличную функцию для этого)
  • Используйте Option Explicit в начале вашего кода ( прочитайте эту статью * 1 048 *)

Код:

Option Explicit


Public Sub Process()

    Dim baseTable As ListObject
    Dim baseTableRow As ListRow
    Dim baseTableName As String

    Dim targetSheet As Worksheet
    Dim targetSheetName As String
    Dim targetFirstRow As Long
    Dim targetColumnCounter As Long

    Dim externalWorkbook As Workbook
    Dim externalTable As ListObject
    Dim externalTableName As String
    Dim externalTableRow As ListRow

    Dim externalFilePath As String
    Dim externalBasePath As String
    Dim externalFileExtension As String
    Dim externalFolderName As String
    Dim externalFileName As String



    ' Adjust the following parameters to fit your needs
    baseTableName = "BaseTable"
    targetSheetName = "RAW"
    externalBasePath = "U:\theFILES\"
    externalFileExtension = "xlsm"
    externalTableName = "Table2"

    targetFirstRow = 1
    targetColumnCounter = 2 ' Column in which the rows will begin being copied/transposed

    ' Initialize objects
    Set baseTable = Range(baseTableName).ListObject '-> This is the table in the "theFILE.xlsm" in "Sheet1" that's holding the file names

    Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)

    ' Loop through each row in the base table
    For Each baseTableRow In baseTable.ListRows

        ' Check if column C is not empty and has a valid file name -Cells(3) is equal to column C if table begins in column A-
        If baseTableRow.Range.Cells(3).Value <> vbNullString Then

            ' Get the folder (or partial path) from column A -Cells(1)-
            externalFolderName = baseTableRow.Range.Cells(1).Value

            ' Get the file name with extension from column L - Cells(12)
            externalFileName = baseTableRow.Range.Cells(12).Value

            ' Build the path to the file
            externalFilePath = externalBasePath & externalFolderName & "\" & externalFileName & "." & externalFileExtension

            ' Validate if file exists
            If Len(Dir(externalFilePath)) = 0 Then
                MsgBox "The file: " & externalFilePath & " does not exist"
            Else
                ' Open the file
                Set externalWorkbook = Workbooks.Open(externalFilePath)

                ' Reference the table in the external workbook (looks in the first worksheet -Worksheets(1)-) (ideally you'd check if the table exists)
                Set externalTable = externalWorkbook.Worksheets(1).ListObjects(externalTableName)

                ' Loop through each row in the external table (except header, and total)
                For Each externalTableRow In externalTable.ListRows

                    ' You'd probably do some validation here...
                    If externalTableRow.Range.Cells(1).Value <> vbNullString Then

                        ' Copy the list row
                        externalTableRow.Range.Copy

                        ' Paste it in the target sheet, transposed
                        targetSheet.Cells(targetFirstRow, targetColumnCounter).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                                                                                              False, Transpose:=True

                        targetColumnCounter = targetColumnCounter + 1

                    End If

                Next externalTableRow

                ' Close the file without saving changes
                externalWorkbook.Close False
            End If

        End If

    Next baseTableRow

End Sub

Дайте мне знать, если это работает!