通过从多张图纸中取出每张图纸的第一行，逐行追加到主图纸中，然后再追加两行

Question

有人能建议我如何一行接一行地追加到主表中吗？从多张表中提取每张表的第一行，然后转到第二行进行追加，假设在第一次迭代中，我们有每张表的每一行，应该将其复制并粘贴为row1、row2、row3到主表，然后在下一次迭代中，每张表的第二行出现，并在主表的末尾添加/追加，这意味着它将是主表的第4行、第5行……等

我甚至尝试了以下用户发送的代码https://stackoverflow.com/users/7444507/michael但是我不能得到正确的输出

Public Sub MergeTabs()
'Merges selected tabs (or all visible tabs if only 1 selected) in current workbook into a new tab
Dim i As Integer, wb As Workbook, w As Window, wsTo As Worksheet, wsFrom As Collection   'Worksheet collection
Dim strScope As String, strNewTab As String
Dim raTarget As Range
Set wb = ActiveWorkbook
Set w = ActiveWindow
Set wsFrom = New Collection
If w.SelectedSheets.Count = 1 Then
For i = 1 To wb.Worksheets.Count
If wb.Worksheets(i).Visible Then wsFrom.Add wb.Worksheets(i)
Next
strScope = "ALL VISIBLE"
Else
For i = 1 To w.SelectedSheets.Count
If w.SelectedSheets(i).Visible Then wsFrom.Add w.SelectedSheets(i)
Next
strScope = wsFrom.Count & " SELECTED"
End If
strNewTab = InputBox("Merge data from " & strScope & " sheets to new sheet named:", "Merge tabs", "All")
If strNewTab = vbNullString Then Exit Sub
Set wsTo = wb.Worksheets.Add(wsFrom(1), Count:=1) 'Add before first selected sheet
wsTo.Name = strNewTab
wsFrom(1).Range("A1").CurrentRegion.Copy
wsTo.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
For i = 2 To wsFrom.Count
wsFrom(i).Range("A2", wsFrom(i).Range("A1").CurrentRegion.Cells(wsFrom(i).Range("A1").CurrentRegion.Cells.Count)).Copy
wsTo.Cells(wsTo.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
Next i
wsTo.Range("A1").Select
MsgBox "Merge Done"
End Sub

Answer 1

请尝试此代码。它首先统计要处理的纸张的最大行数、最大列数和纸张数量。对于最大列数，它只计算图纸的第一行。所以，它一定是床单中较长的！所有这些都是为了能够正确地确定arrFin阵列的尺寸，该阵列将收集所有的线。它将有更多的行，然后需要，乘以最大行数与图纸编号。然后用数据填充数组。我将行与列进行了切换，因为只有数组的第二个维度可以是Redim，从而保留了现有数据。最后，转置后的数组立即放入主表中。它应该工作得很快。。。请确认它按您的需要工作。

Private Sub testApendCopySameRows()
Dim ws As Worksheet, wDest As Worksheet, arrWork As Variant, arrFin As Variant
Dim lastCol As Long, lastC As Long, lastColM As Long, lastR As Long, nrSheets As Long
Dim maxR As Long, maxRows As Long, i As Long, j As Long, k As Long
Set wDest = Worksheets("Master1") ' please, use here your master sheet name
For Each ws In Worksheets
If ws.Name <> wDest.Name Then
'If ws.Name = "sh1" Or ws.Name = "sh2" Then 'used (by me) for testing
nrSheets = nrSheets + 1
lastC = ws.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
If lastC > lastCol Then lastCol = lastC
maxR = ws.Range("A" & Cells.Rows.Count).End(xlUp).Row
If maxR > maxRows Then maxRows = maxR
'End If
End If
Next
ReDim arrFin(1 To lastCol, 1 To maxRows * nrSheets)
ReDim arrWork(1 To 1, 1 To lastCol)
k = 1 'arrFin first row
For i = 1 To maxRows
For Each ws In Worksheets
If ws.Name <> wDest.Name Then
'If ws.Name = "sh1" Or ws.Name = "sh2" Then
lastR = ws.Range("A" & Cells.Rows.Count).End(xlUp).Row
If i <= lastR Then
'input the same rows content in the array:
arrWork = ws.Range(ws.Cells(i, 1), ws.Cells(i, lastCol)).value
For j = 1 To lastCol
arrFin(j, k) = arrWork(1, j)
Next j
k = k + 1
Erase arrWork
ReDim arrWork(1 To 1, 1 To lastCol)
End If
'End If
End If
Next
Next i
ReDim Preserve arrFin(1 To lastCol, 1 To k - 1)
wDest.Range("A1").Resize(UBound(arrFin, 2), UBound(arrFin, 1)).value = _
WorksheetFunction.Transpose(arrFin)
End Sub

不要忘记在Set wDest = Worksheets("Master1")中使用您的母版页名称！