Excel VBA to copy For every row in a table individually

Question

I've now realized my original organizational method is not adequate, so I want to add all the information to a new worksheet called ("RAW")

I am trying to create a Do Loop based a table row count. Here, I'm looping from one "theFILE.xlsm" which opens workbooks one at a time. When the workbook is open I want to copy

Here is what I want to do:

• Open a workbook (sFile),
• Count Table2's databodyrange.count,
• Assign the count to a Variable called BodyCount,
• Copy & Paste desired row,
• Loop for BodyCount's number of times

Every workbook that will be opened has a Table2 but none of the tables are completed so I can't rely if a cell is <> "" as I did with the first Do While Loop.

How do I create a loop to copy 1 row at a time based on the amount of rows in a table.

Here is what

Sub every_one() ''compile everything into 1 list

''''DIMENSIONS
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

I am new to For...Next Loops. Any and all tips, tricks or hints will be greatly appreciated.

Here are some pictures,

Answer 1

I tried to follow your code, but ended up somehow tangled...

My code assumes:

• You have an Excel table in Sheet1 (where the file names are) I called it BaseTable
• You are running the macro in the workbook that has that table
• Your target sheet "RAW" is in the same workbook where you're running the macro
• Your external workbooks have the Table2 in the first sheet

Suggestions:

• Make a backup of your files and data before trying this code
• Step through the code pressing F8 and adjust it to fit your needs
• Reviewing your code:
  • Try to avoid using select and activate see this answer
  • Try to separate inputs from other statements (assign them to variables)
  • Indent your code (This plugin has a great feature for that)
  • Use Option Explicit at the beginning of your code (read this article)

Code:

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

Let me know if it works!