时间戳

首页 > 解决方案 > 通过从多张工作表中获取每张工作表的第一行，然后逐行追加到主工作表中，然后在第二行追加

excel - 通过从多张工作表中获取每张工作表的第一行，然后逐行追加到主工作表中，然后在第二行追加

问题描述

有人可以建议我如何通过从多张工作表中获取每张工作表的第一行然后移动到附加的第二行来逐行附加到主工作表中，假设在第一次迭代中，我们有每张工作表的第一行，那应该复制并粘贴为第1行，第2行，第3行到主表中，然后在下一次迭代中，每张表的第二行出现并在主表末尾添加/附加意味着它将是第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

标签： excelvbaexcel-formula

解决方案

请试试这个代码。首先统计要处理的最大行数、最大列数和最大张数。对于最大列数，它仅计算工作表第一行。因此，它必须是纸张中较长的！所有这些都是为了能够正确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")！

推荐阅读