请求修改VBA代码：批量导入工作簿数据并添加来源文件名

核心解决点 #

• 以值的形式粘贴数据，彻底消除跨工作簿链接错误
• 自动为每条导入数据添加来源工作簿文件名（默认放在A列，数据从B列开始，可调整至DA列）
• 精准遍历指定文件夹内所有工作簿，定位目标工作表的有效数据范围

完整代码 #

Sub ImportDataWithSource()
    Dim sourceFolderPath As String
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    Dim fileName As String
    
    ' 绑定目标工作簿与工作表（当前运行代码的TOT_Importfiler.xlsm）
    Set targetWB = ThisWorkbook
    Set targetWS = targetWB.Worksheets("Blad1")
    
    ' 让用户选择要遍历的文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择目标文件夹"
        If .Show = -1 Then
            sourceFolderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "未选择文件夹，程序终止"
            Exit Sub
        End If
    End With
    
    ' 关闭屏幕刷新和事件，提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 遍历文件夹内所有Excel格式文件
    fileName = Dir(sourceFolderPath & "*.xls*")
    Do While fileName <> ""
        ' 跳过当前目标工作簿本身
        If fileName <> targetWB.Name Then
            On Error Resume Next
            Set sourceWB = Workbooks.Open(sourceFolderPath & fileName, ReadOnly:=True)
            On Error GoTo 0
            
            If Not sourceWB Is Nothing Then
                ' 检查源工作簿是否存在「Import fil」工作表
                On Error Resume Next
                Set sourceWS = sourceWB.Worksheets("Import fil")
                On Error GoTo 0
                
                If Not sourceWS Is Nothing Then
                    ' 获取源数据A列最后有效行
                    lastRowSource = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
                    
                    ' 仅处理第5行及以下的有效数据
                    If lastRowSource >= 5 Then
                        ' 获取目标工作表下一个空白行的行号
                        lastRowTarget = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row + 1
                        
                        ' 复制源数据并以值粘贴到目标B列起始位置
                        sourceWS.Range("A5:CZ" & lastRowSource).Copy
                        targetWS.Range("B" & lastRowTarget).PasteSpecial Paste:=xlPasteValues
                        
                        ' 在A列批量填充来源文件名
                        targetWS.Range("A" & lastRowTarget & ":A" & lastRowTarget + (lastRowSource - 5)).Value = fileName
                        
                        ' 若需将文件名放在DA列，注释上方A列代码，取消下方注释
                        ' targetWS.Range("DA" & lastRowTarget & ":DA" & lastRowTarget + (lastRowSource - 5)).Value = fileName
                    End If
                    
                    ' 关闭源工作簿，不保存任何修改
                    sourceWB.Close SaveChanges:=False
                    Set sourceWS = Nothing
                End If
                Set sourceWB = Nothing
            End If
        End If
        fileName = Dir()
    Loop
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.CutCopyMode = False
    
    MsgBox "数据导入完成！"
End Sub

关键细节说明 #

• 值粘贴逻辑：使用xlPasteValues参数直接粘贴单元格数值，完全规避公式引用带来的跨工作簿链接问题
• 文件名批量赋值：通过一次性给整列赋值的方式，比逐行写入效率更高
• 异常防护：添加了工作簿、工作表的存在性检查，避免因文件结构异常导致程序崩溃
• 性能优化：禁用屏幕刷新和事件触发，减少运行过程中的卡顿

内容的提问来源于stack exchange，提问作者aeso lin