Vba code to compile specific details from different excel file to one file from folder

You can do this really quickly and easily with Power Query.

The following query returns all files in your folder, as a table, and applies a function query for each column returned:

let
    Source = Folder.Files("C:\Temp\Combine"),
    #"Get A" = Table.AddColumn(Source, "Agency", each fnColumnA([Content])),
    #"Get B" = Table.AddColumn(#"Get A", "Advertiser", each fnColumnB([Content])),
    #"Get C" = Table.AddColumn(#"Get B", "Start / End", each fnColumnC([Content])),
    #"Get D" = Table.AddColumn(#"Get C", "Net Amount", each fnColumnD([Content])),
    #"Removed Other Columns" = Table.SelectColumns(#"Get D",{"Agency", "Advertiser", "Start / End", "Net Amount"})
in
    #"Removed Other Columns"

The four function queries, to return your four columns are identical, apart from the cell referenced. Name them consistently with the function names used in the CombineFromFolder query.

let GetColumnA = (wb as binary) =>
    let
        Source = Excel.Workbook(wb, null, true),
        Sheet = Source{[Item="Sheet1",Kind="Sheet"]}[Data],
        Value = Sheet{9}[Column1]
    in
        Value
in
    GetColumnA

let GetColumnB = (wb as binary) =>
    let
        Source = Excel.Workbook(wb, null, true),
        Sheet = Source{[Item="Sheet1",Kind="Sheet"]}[Data],
        Value = Sheet{17}[Column1]
    in
        Value
in
    GetColumnB

let GetColumnC = (wb as binary) =>
    let
        Source = Excel.Workbook(wb, null, true),
        Sheet = Source{[Item="Sheet1",Kind="Sheet"]}[Data],
        Value = Sheet{11}[Column5]
    in
        Value
in
    GetColumnC

let GetColumnD = (wb as binary) =>
    let
        Source = Excel.Workbook(wb, null, true),
        Sheet = Source{[Item="Sheet1",Kind="Sheet"]}[Data],
        Value = Sheet{45}[Column7]
    in
        Value
in
    GetColumnD

Example workbook attached - just change the folder path in the CombineFromFolder query, then refresh. To update, simply refresh the query.

Hi Olly,

Thanks for the reply!

Actually i do not have power query install on my system.

Is it possible by macro.

I am using below code but it is not working.

Sub Example()
Dim Mypath As String
Dim wbk As Workbook
Dim Targetfile As Worksheet
'Where all files are located
Mypath = "C:\Users\r.shi\Desktop\New folder"
'In this workbook I want to compile details (Unsaved)
Set Targetfile = ThisWorkbook.Sheets("Sheet1")
Do While Mypath <> ""
Set wbk = Mypath.Workbooks.Worksheets("Sheet1")
Range("A10:D10").Copy
Targetfile.Activate Range("A2").PasteSpecial
Range("A18:B18").Copy
Targetfile.Activate
ActiveCell.Offset(0, 1).PasteSpecial
Range("E12").Copy
Targetfile.Activate
ActiveCell.Offset(0, 1).PasteSpecial
Range("G46").Copy
Targetfile.Activate
ActiveCell.Offset(0, 1).PasteSpecial
ActiveCell.Offset(1, 0).Activate
Loop
End Sub

Regards,

upa

I'd recommend installing Power Query, and learning the basics. It's SO MUCH better than VBA for doing this kind of data processing.

However - here's a VBA solution. It will be much slower than the Power Query version:

Sub CombineFromFolder()
    
    Dim stDirectory As String
    Dim stFile As String
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet
    Dim wsTgt As Worksheet
    Dim tbTgt As ListObject
    Dim lWB As Long
    
    Const sTableName As String = "tbCombine"
    Set wsTgt = Sheet1  'change to your output sheet, if needed
    
    On Error GoTo Terminate
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            stDirectory = .SelectedItems(1) & "\"
        Else
            Err.Raise -1001, , "No directory"
        End If
    End With
    
    If Not TableExists(wsTgt, sTableName) Then
        If Not MakeTable(wsTgt.Range("A1"), sTableName) Then
            Err.Raise -1002, , "No output table"
        End If
    End If
    
    Set tbTgt = wsTgt.ListObjects(sTableName)
    With tbTgt
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Rows.Delete
    End With
    
    stFile = Dir(stDirectory)

    While (stFile <> "")
        Application.StatusBar = "Processing file: " & stFile
        Set wbSrc = Workbooks.Open(stDirectory & stFile)
        lWB = lWB + 1
        
        Set wsSrc = wbSrc.Worksheets(1) ' change source sheet if needed - currently looks at first sheet

        With tbTgt.ListRows.Add
            .Range(1, 1).Value = wsSrc.Range("A10").Value
            .Range(1, 2).Value = wsSrc.Range("A18").Value
            .Range(1, 3).Value = wsSrc.Range("E12").Value
            .Range(1, 4).Value = wsSrc.Range("G46").Value
        End With
        
        wbSrc.Close SaveChanges:=False
        stFile = Dir
        DoEvents
    Wend

    Application.ScreenUpdating = True
    MsgBox "Updated data from " & lWB & " source files", vbInformation + vbOKOnly

Terminate:
    If Err Then
        Debug.Print "Error", Err.Number, Err.Description
        Err.Clear
    End If
    With Application
        .StatusBar = False
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

End Sub

Function TableExists(ByRef ws As Worksheet, ByVal sTableName As String) As Boolean
    
    Dim lo As ListObject
    
    On Error GoTo Terminate
    
    For Each lo In ws.ListObjects
        If lo.Name = sTableName Then TableExists = True
    Next lo
    
Terminate:
    If Err Then
        TableExists = False
        Err.Clear
    End If
    
End Function

Function MakeTable(ByRef cTableRange As Range, ByVal sTableName As String)
    
    Dim vHeaders() As Variant
    Dim i As Integer
    
    On Error GoTo Terminate
    
    vHeaders = Array("Agency", "Advertise", "Start", "End")
    Set cTableRange = cTableRange.Resize(1, UBound(vHeaders) + 1)
    cTableRange.Value = vHeaders
    Sheet1.ListObjects.Add(SourceType:=xlSrcRange, Source:=cTableRange, xllistobjecthasheaders:=xlYes).Name = sTableName
    
Terminate:
    If Err Then
        MakeTable = False
        Err.Clear
    Else
        MakeTable = True
    End If
End Function

Happy to help. If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. You can also Add Reputation to those who helped you. Thanks.