VBA合并Excel文件夹文件：调整复制内容起始行至A2并逐行追加

问题描述 #

已实现遍历指定文件夹内Excel文件并复制内容到目标工作簿，但粘贴位置异常：要么固定到第21行，要么直接粘贴到工作表顶部。需求是从A2单元格开始，每次复制的内容依次追加到下一行。

有问题的代码段 #

• 固定粘贴到第21行的代码：

'Set the destrange
Set destrange = BaseWks.Range("A2" & rnum)

• 粘贴到工作表顶部的代码：

'Set the destrange
Set destrange = BaseWks.Range("A" & rnum)

问题根源 #

1. 初始rnum = 1，"A2" & rnum会拼接成A21（字符串拼接而非单元格地址计算），导致每次都定位到第21行
2. 直接用"A" & rnum会从A1开始，不符合从A2启动的需求

修改后的完整代码 #

Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

    '目标文件夹路径
    MyPath = "C:\Users\jlinney\OneDrive - Distell\Desktop\Personal\NOMAD\Global Mobility\Excel From"

    '自动补全路径末尾的斜杠
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    '检查文件夹是否有Excel文件
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "未找到文件"
        Exit Sub
    End If

    '将所有Excel文件名存入数组
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    '关闭Excel的自动更新以提升运行效率
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    '指定目标工作簿和工作表
    Dim wbk As Workbook
    Dim ws As Worksheet
    
    Set wbk = Workbooks("Excel to.xlsm")
    Set BaseWks = wbk.Worksheets("Sheet1")
    
    '初始定位到A2单元格
    rnum = 2

    '遍历所有目标文件
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then
                On Error Resume Next
                '获取源文件的A2:H2区域
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A2:H2")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    '如果源区域列数超过目标表，跳过该文件
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count

                    '检查目标表剩余行数是否足够
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "工作表剩余行数不足"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        '定位到当前要粘贴的起始单元格
                        Set destrange = BaseWks.Cells(rnum, "A")

                        '匹配源区域的大小
                        With sourceRange
                            Set destrange = destrange.Resize(.Rows.Count, .Columns.Count)
                        End With
                        '复制值到目标区域
                        destrange.Value = sourceRange.Value

                        '更新下一次粘贴的起始行号
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    '恢复Excel的自动更新设置
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

关键修改点 #

• 将rnum初始值从1改为2，确保第一次粘贴从A2开始
• 替换目标区域定位代码为Set destrange = BaseWks.Cells(rnum, "A")，避免字符串拼接错误，精准定位当前起始行
• 保持每次粘贴后rnum = rnum + SourceRcount，实现内容依次追加

内容的提问来源于stack exchange，提问作者Julia Linney