VBA批量导入数据需求：需在粘贴数据旁添加源文件名标识

你当前的VBA代码已能从多个源文件复制指定数据到目标工作表，但手动固定范围填充文件名的方式（SFname2.Range("K3", "K18").Value = SFlname）无法适配每次复制数据的行数变化，以下是针对性修改方案：

核心修改思路 #

1. 复制数据前记录目标工作表的起始粘贴行，摆脱固定行号的局限
2. 复制完成后计算本次粘贴的数据行数
3. 在目标列（此处为K列）对应行数范围内批量填充源文件名

修改后的完整代码 #

Sub OpenFilesCopyPasteVI()

Dim SFile As Workbook
Dim SFname As Worksheet
Dim SFname2 As Worksheet
Dim SFlname As String
Dim I As Long
Dim DFile As Workbook
Dim Acellrng As String
Dim pasteStartRow As Long ' 记录粘贴起始行
Dim pasteRowCount As Long ' 记录粘贴数据的行数

Pth = "C:\XYZ\"
Application.ScreenUpdating = False

Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Set SFname2 = SFile.Worksheets("Sheet3")
' 修正：限定Range父对象为SFname，避免ActiveSheet干扰
numrows = SFname.Range("A1", SFname.Range("A1").End(xlDown)).Rows.Count

For I = 1 To numrows

SFlname = SFname.Range("A" & I).Value

If SFname.Range("A" & I).Value <> "" Then

Workbooks.Open Pth & SFlname
Set DFile = Workbooks(SFlname)
 
' 修正：指定Find的父对象为源文件工作表，避免歧义
DFile.ActiveSheet.Cells.Find(What:="ABC", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True).Activate
Acellrng = ActiveCell.Address

' 记录粘贴前目标工作表的最后行，确定粘贴起始位置
pasteStartRow = SFname2.Cells(SFname2.Rows.Count, "C").End(xlUp).Row + 1

' 复制数据到目标位置
DFile.ActiveSheet.Range(Acellrng, DFile.ActiveSheet.Range(Acellrng).End(xlDown).End(xlToRight)).Copy _
    Destination:=SFname2.Cells(pasteStartRow, "C")

' 计算本次粘贴的行数
pasteRowCount = DFile.ActiveSheet.Range(Acellrng, DFile.ActiveSheet.Range(Acellrng).End(xlDown)).Rows.Count

' 批量填充源文件名到K列对应行
SFname2.Range("K" & pasteStartRow, "K" & pasteStartRow + pasteRowCount - 1).Value = SFlname

DFile.Close SaveChanges:=False ' 明确关闭不保存，避免弹窗

End If

Next I

MsgBox "job done"

Application.ScreenUpdating = True

End Sub

关键修改点说明 #

• 新增pasteStartRow和pasteRowCount变量，动态获取每次粘贴的位置和行数，彻底适配不同源文件的数据行数
• 给所有Range/Find操作指定明确的父对象（如DFile.ActiveSheet、SFname），避免因ActiveSheet切换导致的逻辑错误
• 关闭文件时添加SaveChanges:=False，防止源文件被误修改后弹出保存提示

内容的提问来源于stack exchange，提问作者deepankar haldar