Excel VBA 分别复制 table 中的每一行
Excel VBA to copy For every row in a table individually
我现在意识到我原来的组织方法是不够的，所以我想将所有信息添加到一个名为 ("RAW") 的新工作表中
我正在尝试创建一个基于 table 行数的 Do 循环。在这里，我从一个“theFILE.xlsm”开始循环，它一次打开一个工作簿。当工作簿打开时我想复制
这是我想要做的：
- 打开工作簿 (sFile)，
- 计算表 2 的 databodyrange.count、
- 将计数分配给名为 BodyCount 的变量，
- 复制并粘贴所需的行，
- 循环 BodyCount 的次数
每个将打开的工作簿都有一个 Table2，但是 table 中的 none 已经完成，所以我不能像第一个单元格那样依赖 <>“”执行 While 循环。
如何创建循环以根据 table 中的行数一次复制 1 行。
这是什么
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
我是 For...Next 循环的新手。我们将不胜感激任何提示、技巧或提示。
这里有一些图片，
我尝试按照您的代码进行操作，但最终不知何故纠结...
我的代码假定：
- 你在
Sheet1 中有一个 Excel table（文件名所在的位置），我将其命名为 BaseTable
- 您是 运行 工作簿中具有 table
的宏
- 您的目标 sheet "RAW" 与您 运行 宏
在同一个工作簿中
- 您的外部工作簿在第一个 sheet
中有 Table2
建议：
- 在尝试此代码之前先对您的文件和数据进行
backup
- 按 F8 单步执行代码并根据您的需要进行调整
- 审查您的代码：
- 尽量避免使用
select和activatesee this answer
- 尝试将输入与其他语句分开（将它们分配给
variables）
Indent 您的代码（This plugin 有一个很棒的功能）- 在代码开头使用
Option Explicit (read this article)
代码：
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
如果有效请告诉我！
我现在意识到我原来的组织方法是不够的，所以我想将所有信息添加到一个名为 ("RAW") 的新工作表中
我正在尝试创建一个基于 table 行数的 Do 循环。在这里，我从一个“theFILE.xlsm”开始循环，它一次打开一个工作簿。当工作簿打开时我想复制
这是我想要做的：
- 打开工作簿 (sFile)，
- 计算表 2 的 databodyrange.count、
- 将计数分配给名为 BodyCount 的变量，
- 复制并粘贴所需的行，
- 循环 BodyCount 的次数
每个将打开的工作簿都有一个 Table2，但是 table 中的 none 已经完成，所以我不能像第一个单元格那样依赖 <>“”执行 While 循环。
如何创建循环以根据 table 中的行数一次复制 1 行。
这是什么
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
我是 For...Next 循环的新手。我们将不胜感激任何提示、技巧或提示。
这里有一些图片，
我尝试按照您的代码进行操作，但最终不知何故纠结...
我的代码假定：
- 你在
Sheet1中有一个 Excel table（文件名所在的位置），我将其命名为BaseTable - 您是 运行 工作簿中具有 table 的宏
- 您的目标 sheet "RAW" 与您 运行 宏 在同一个工作簿中
- 您的外部工作簿在第一个 sheet 中有
Table2
建议：
- 在尝试此代码之前先对您的文件和数据进行
backup - 按 F8 单步执行代码并根据您的需要进行调整
- 审查您的代码：
- 尽量避免使用
select和activatesee this answer - 尝试将输入与其他语句分开（将它们分配给
variables） Indent您的代码（This plugin 有一个很棒的功能）- 在代码开头使用
Option Explicit(read this article)
- 尽量避免使用
代码：
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
如果有效请告诉我！