将数据附加到最后一行

Question

我有以下 VBA 查询。它将每个选项卡中的数据复制并粘贴到同一区域中，理想情况下我希望将其附加到该范围的最后一行数据中。另外，最后一行数据可能未完全填满。预先感谢，这是我的代码：

Sub CopyData()
    Dim tabNames() As Variant
    Dim sourceRange As Range
    Dim destinationRange As Range
    Dim lastRow As Long
    Dim i As Long
    Dim tabName As Variant
    
    ' List of tab names
    tabNames = Array("Tab1", "Tab2", "Tab3", "Tab4", "Tab5")
    
    ' Loop through each tab name
    For Each tabName In tabNames
        ' Set the source range to copy
        Set sourceRange = Sheets(tabName).Range("B1:AI6")
        
        ' Loop through the merged cells in the source range and unmerge them
        For Each unmergedCell In sourceRange
            If unmergedCell.MergeCells Then
                unmergedCell.MergeCells = False
            End If
        Next unmergedCell
        
        ' Copy the source range
        sourceRange.Copy
        
        ' Set the destination range for pasting
        Set destinationRange = Sheets("Append").Range("B2")
        
        ' Add a new column with the tab name
        destinationRange.Offset(0, -1).Resize(destinationRange.Rows.Count, 1).Value = tabName
        
        ' Paste the copied data
        destinationRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        
        ' Fill down the tab name column for the entire range
        destinationRange.Offset(0, -1).Resize(destinationRange.Rows.Count + 33, 1).FillDown
        
        ' Clear clipboard
        Application.CutCopyMode = False
        
        ' Get the last row in the destination range
        lastRow = destinationRange.Row + destinationRange.Columns.Count - 1
        
        ' Loop through each row and fill down values in columns B and C
        For i = destinationRange.Row To lastRow
            If IsEmpty(destinationRange.Offset(i - destinationRange.Row, 1)) Then
                destinationRange.Offset(i - destinationRange.Row, 1).FormulaR1C1 = "=R[-1]C"
                destinationRange.Offset(i - destinationRange.Row, 1).Value = destinationRange.Offset(i - destinationRange.Row, 1).Value
            End If
            If IsEmpty(destinationRange.Offset(i - destinationRange.Row, 2)) Then
                destinationRange.Offset(i - destinationRange.Row, 2).FormulaR1C1 = "=R[-1]C"
                destinationRange.Offset(i - destinationRange.Row, 2).Value = destinationRange.Offset(i - destinationRange.Row, 2).Value
            End If
        Next i
    Next tabName
End Sub

它复制了以前的数据，基本上只留下一组结果

Answer 1

试试这个：

Sub CopyData()
    Dim tabNames() As Variant
    Dim sourceRange As Range
    Dim destinationRange As Range
    Dim lastRow As Long
    Dim i As Long
    Dim tabName As Variant, wb As Workbook, nRows As Long, nCols As Long, rw As Range, n As Long
    
    
    Set wb = ThisWorkbook 'or ActiveWorkbook...
    tabNames = Array("Tab1", "Tab2", "Tab3", "Tab4", "Tab5")
    
    Set destinationRange = wb.Worksheets("Append").Range("B2") 'first paste goes here
    
    For Each tabName In tabNames
        
        Set sourceRange = wb.Worksheets(tabName).Range("B1:AI6")
        nRows = sourceRange.Columns.Count 'transposing on paste...
        nCols = sourceRange.Rows.Count
        sourceRange.MergeCells = False
        
        destinationRange.Offset(0, -1).Resize(nRows).Value = tabName 'fill in tab name in ColA
        
        sourceRange.Copy
        destinationRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
                                      SkipBlanks:=False, Transpose:=True
        
        'fill empty cells in Cols B and C
        For Each rw In destinationRange.Resize(nRows, nCols).Rows
            If rw.Row > destinationRange.Row Then 'skip row#1
                With rw.Cells(1)
                    If Len(.Value) = 0 Then .Value = .Offset(-1).Value
                End With
                With rw.Cells(2)
                    If Len(.Value) = 0 Then .Value = .Offset(-1).Value
                End With
            End If
        Next rw
        
        Set destinationRange = destinationRange.Offset(nRows) 'next paste destination
        
    Next tabName
End Sub