Macro to Extract Specific cell data from Multiple CSV files in a folder into a new summary Excel file

[Ana_kin]

Hi,

I have a a folder with 100 csv files from specific Cells and paste them to a summary excel file. For example-

from origin_file_1.csv to the dest_file.xlsm
B7-->K2
B8-->L2
B10--> M2

from origin_file_2.csv to the dest_file.xlsm
B7-->K3
B8-->L3
B10--> M3

and so forth. Thanks in advance!

 

[Ana_kin]

Hi,

I have a a folder with 100 csv files and want to copy cell values from specific Cells in those file and paste them to a summary excel file. For example-

from origin_file_1.csv to the dest_file.xlsm
B7-->K2
B8-->L2
B10--> M2

from origin_file_2.csv to the dest_file.xlsm
B7-->K3
B8-->L3
B10--> M3

and so forth.

The following code by @John_w works for copying from a single file, but I need to copy from multiple files at eh same time.

Thanks in advance!

Public Sub Copy_Values_From_Workbooks()

    Dim matchWorkbooks As String
    Dim destSheet As Worksheet, r As Long
    Dim folderPath As String
    Dim wbFileName As String
    Dim fromWorkbook As Workbook
   
    'Folder path and wildcard workbook files to import cells from
   
    matchWorkbooks = "D:\XXX\XXX\XXX\XXX.csv"                                       'CHANGE THIS
    
    
    'Define destination sheet
   
    Set destSheet = ActiveWorkbook.Worksheets("Sheet1")                                'CHANGE THIS
   
    destSheet.Cells.Clear
    r = 0
   
    Application.ScreenUpdating = False
           
    folderPath = Left(matchWorkbooks, InStrRev(matchWorkbooks, "\"))
    wbFileName = Dir(matchWorkbooks)
    While wbFileName <> vbNullString
        Set fromWorkbook = Workbooks.Open(folderPath & wbFileName)
        With fromWorkbook.Worksheets(1)
            destSheet.Range("K2").Offset(r).Value = .Range("B7").Value
            destSheet.Range("L2").Offset(r).Value = .Range("B8").Value
            destSheet.Range("M2").Offset(r).Value = .Range("B10").Value
            r = r + 1
        End With
        fromWorkbook.Close savechanges:=False
        DoEvents
        wbFileName = Dir
    Wend
   
    Application.ScreenUpdating = True
   
    MsgBox "Finished"
   
End Sub

 

[John_w]

The following code by @John_w works for copying from a single file, but I need to copy from multiple files at eh same time.

No, it already copies from multiple files because it uses a Dir function loop which finds file names which match the wildcard pattern in the matchWorkbooks string. Therefore the code should import all the .csv files in the specified folder with this change:

matchWorkbooks = "D:\XXX\XXX\XXX\*.csv"

 

[Ana_kin]

No, it already copies from multiple files because it uses a Dir function loop which finds file names which match the wildcard pattern in the matchWorkbooks string. Therefore the code should import all the .csv files in the specified folder with this change:

matchWorkbooks = "D:\XXX\XXX\XXX\*.csv"

Dear @John_w Thanks a lot! I did not notice the "*", was using indvidual file names instead. It works perfectly fine now. Thanks again!
I am posting the final code-

Public Sub Copy_Values_From_Workbooks()

    Dim matchWorkbooks As String
    Dim destSheet As Worksheet, r As Long
    Dim folderPath As String
    Dim wbFileName As String
    Dim fromWorkbook As Workbook
   
    'Folder path and wildcard workbook files to import cells from
   
    matchWorkbooks = "X:\XXX\XXX\XXX\*.csv"                                       'CHANGE ONLY THE XX PART
    
    
    'Define destination sheet
   
    Set destSheet = ActiveWorkbook.Worksheets("Sheet1")                                'CHANGE THIS
   
    destSheet.Cells.Clear
    r = 0
   
    Application.ScreenUpdating = False
           
    folderPath = Left(matchWorkbooks, InStrRev(matchWorkbooks, "\"))
    wbFileName = Dir(matchWorkbooks)
    While wbFileName <> vbNullString
        Set fromWorkbook = Workbooks.Open(folderPath & wbFileName)
        With fromWorkbook.Worksheets(1)
            destSheet.Range("K2").Offset(r).Value = .Range("B7").Value / 100000
            destSheet.Range("L2").Offset(r).Value = .Range("B8").Value / 100000
            destSheet.Range("M2").Offset(r).Value = .Range("B10").Value / 100000
            r = r + 1
        End With
        fromWorkbook.Close savechanges:=False
        DoEvents
        wbFileName = Dir
    Wend
   
    Application.ScreenUpdating = True
   
    MsgBox "Finished"
   
End Sub