我有20多个源文件，我正在将数据整理到一个文件中，面临着将源文件名作为标识符的问题

Question

到目前为止，我的代码确实粘贴了所有源文件中的选定数据，但我还需要源文件名来识别哪些数据属于哪个源文件，并且该名称应该出现在每次粘贴数据的列旁边。

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
Pth = "C:XYZ"
Application.ScreenUpdating = False
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Set SFname2 = SFile.Worksheets("Sheet3")
numrows = SFname.Range("A1", 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)

Cells.Find(What:="ABC", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True).Activate
Acellrng = ActiveCell.Address
Range(Acellrng).Select
ActiveSheet.Range(Selection, Selection.End(xlDown).End(xlToRight)).Copy Destination:=SFile.Worksheets("Sheet3").Cells(SFile.Worksheets("Sheet3").Rows.Count, "C").End(xlUp).Offset(1)
DFile.Close
**'I need help to automate this part where I need the source file name in the last column each time beside the data pasted**
SFname2.Range("K3", "K18").Value = SFlname
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
End Sub

Answer 1

试试这个：

Sub OpenFilesCopyPasteVI()
Const PTH As String = "C:XYZ" 'use const for fixed values

Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
Dim SFlname As String, I As Long, DFile As Workbook
Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range

Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Set SFname2 = SFile.Worksheets("Sheet3")
Application.ScreenUpdating = False

For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row
SFlname = SFname.Range("A" & I).Value
If Len(SFlname) > 0 Then
Set DFile = Workbooks.Open(PTH & SFlname)
Set ws = DFile.Sheets(1) 'or other specifc sheet
Set Acellrng = ws.Cells.Find(What:="ABC", _
LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)

If Not Acellrng Is Nothing Then
Set rngCopy = ws.Range(Acellrng, Acellrng.End(xlDown).End(xlToRight))
Set rngDest = SFname2.Cells(Rows.Count, "C").End(xlUp).Offset(1)
rngCopy.Copy rngDest
'populate the file name in Column K next to the copied data
rngDest.EntireRow.Columns("K").Resize(rngCopy.Rows.Count).Value = SFlname
End If
DFile.Close savechanges:=False
End If
Next I

MsgBox "job done"
Application.ScreenUpdating = True
End Sub