I have 20 odd source file from where I am collating data into one file, facing issue in pulling the-CodePudding

My Code so far does paste the selected data from all the source files, however I also need the source file name to recognize which data belongs to which source file and this name should occur beside the column where data is pasted each time.

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

CodePudding user response：

Try this out:

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