VBA to pull data from select cells in multiple workbooks in same folder and copy it to one master book

[CutterSoilMixing]

Hello everyone,

I regularly have to update a master spreadsheet with data from multiple excel files. The excel files are all in the same format and the data I need is always in the same cells and sheet (sheet 1). The files are also always stored in the same folder. I have a code that allows me to select each file individually and then copies the data I need into the master. I was wondering if there is a way to copy the data from all files in the folder at the same time so that I only select the folder instead every single file?

Thanks for your help!

Private Sub CommandButton1_Click()

    Dim FileLocation As String
    
    FileLocation = Application.GetOpenFilename
    If FileLocation = "False" Then
        Beep
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Set ImportWorkbook = Workbooks.Open(Filename:=FileLocation)
    
    'date'
    ImportWorkbook.Worksheets("sheet1").Range("B6").Copy ThisWorkbook.Worksheets("data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    'panel id'
    ImportWorkbook.Worksheets("sheet1").Range("B5").Copy ThisWorkbook.Worksheets("data").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
    'start time'
    ImportWorkbook.Worksheets("sheet1").Range("B7").Copy ThisWorkbook.Worksheets("data").Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
    'final depth'
    ImportWorkbook.Worksheets("sheet1").Range("B33").Copy ThisWorkbook.Worksheets("data").Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
    'end time'
    ImportWorkbook.Worksheets("sheet1").Range("B33").Copy ThisWorkbook.Worksheets("data").Range("E" & Rows.Count).End(xlUp).Offset(1, 0)
    'cut depth'
    ImportWorkbook.Worksheets("sheet1").Range("B43").Copy ThisWorkbook.Worksheets("data").Range("F" & Rows.Count).End(xlUp).Offset(1, 0)
    'rig'
    ImportWorkbook.Worksheets("sheet1").Range("B56").Copy ThisWorkbook.Worksheets("data").Range("I" & Rows.Count).End(xlUp).Offset(1, 0)
    'total slurry'
    ImportWorkbook.Worksheets("sheet1").Range("B35").Copy ThisWorkbook.Worksheets("data").Range("H" & Rows.Count).End(xlUp).Offset(1, 0)
    'operator'
    ImportWorkbook.Worksheets("sheet1").Range("B4").Copy ThisWorkbook.Worksheets("data").Range("J" & Rows.Count).End(xlUp).Offset(1, 0)
    

    ImportWorkbook.Close
    Application.ScreenUpdating = True
End Sub

 

[HighAndWilder]

Does this do what you want?

Add this code to a standard code module in the same workbook as the data is to be copied to.

Public Sub subPullDataFromSelectCellsInMultipleWorkbooks()
Dim strFileName As String
Dim strFolder As String
Dim WbDestination As Workbook
Dim WsDestination As Worksheet
Dim WsSource As Worksheet
Dim rngSource As Range
Dim rng As Range
Dim intLoop As Integer
Dim lngNextRow As Long
Dim Wbsource As Workbook
Dim rngTarget As Range

    ActiveWorkbook.Save
    
    Set WbDestination = ActiveWorkbook
  
    Set WsDestination = WbDestination.Worksheets("Data")
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            strFolder = .SelectedItems(1)
        End If
    End With
    
    If strFolder = "" Then
        Exit Sub
    End If
    
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If
        
    strFileName = Dir(strFolder & "*.xls*")
    
    Do While strFileName <> ""
            
        Workbooks.Open strFolder & strFileName
            
        Set Wbsource = ActiveWorkbook
            
        Set WsSource = Wbsource.Sheets(1)
         
        ' Source cells.
        Set rngSource = WsSource.Range("B6,B5,B7,B33,B33,B43,B56,B35,B4")
            
        ' Used to indicate the columns to copy data to.
        Set rngTarget = WsDestination.Range("A1,B1,C1,D1,E1,F1,I1,H1,J1")
            
        intLoop = 0
            
        ' Loop throiugh each of the source cells.
        For Each rng In rngSource.Cells
                
            intLoop = intLoop + 1
                
            lngNextRow = WsDestination.Cells(Rows.Count, rngTarget.Cells(1, intLoop).Column).End(xlUp).Row + 1
                
            WsDestination.Cells(lngNextRow, rngTarget.Cells(1, intLoop).Column).Value = rng.Value
            
        Next rng
            
        Wbsource.Close
        
        strFileName = Dir
    
    Loop
    
    WbDestination.Save

    MsgBox "Finished.", vbInformation, "Confirmation"

End Sub

 

[CutterSoilMixing]

Apologies for the late response! Thanks so much HighAndWilder! Exactly what I was looking for.

 

[CutterSoilMixing]

Does this do what you want?

Add this code to a standard code module in the same workbook as the data is to be copied to.

Public Sub subPullDataFromSelectCellsInMultipleWorkbooks()
Dim strFileName As String
Dim strFolder As String
Dim WbDestination As Workbook
Dim WsDestination As Worksheet
Dim WsSource As Worksheet
Dim rngSource As Range
Dim rng As Range
Dim intLoop As Integer
Dim lngNextRow As Long
Dim Wbsource As Workbook
Dim rngTarget As Range

    ActiveWorkbook.Save
   
    Set WbDestination = ActiveWorkbook
 
    Set WsDestination = WbDestination.Worksheets("Data")
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            strFolder = .SelectedItems(1)
        End If
    End With
   
    If strFolder = "" Then
        Exit Sub
    End If
   
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If
       
    strFileName = Dir(strFolder & "*.xls*")
   
    Do While strFileName <> ""
           
        Workbooks.Open strFolder & strFileName
           
        Set Wbsource = ActiveWorkbook
           
        Set WsSource = Wbsource.Sheets(1)
        
        ' Source cells.
        Set rngSource = WsSource.Range("B6,B5,B7,B33,B33,B43,B56,B35,B4")
           
        ' Used to indicate the columns to copy data to.
        Set rngTarget = WsDestination.Range("A1,B1,C1,D1,E1,F1,I1,H1,J1")
           
        intLoop = 0
           
        ' Loop throiugh each of the source cells.
        For Each rng In rngSource.Cells
               
            intLoop = intLoop + 1
               
            lngNextRow = WsDestination.Cells(Rows.Count, rngTarget.Cells(1, intLoop).Column).End(xlUp).Row + 1
               
            WsDestination.Cells(lngNextRow, rngTarget.Cells(1, intLoop).Column).Value = rng.Value
           
        Next rng
           
        Wbsource.Close
       
        strFileName = Dir
   
    Loop
   
    WbDestination.Save

    MsgBox "Finished.", vbInformation, "Confirmation"

End Sub

I'm applying this macro to many other data collection tasks I frequently have to do and it's very helpful!

Currently, I'm trying to compile a list of test results in one spreadsheet. Each test result is stored in a separate excel file together with some info on the test specimen. The VBA code worked perfectly but I found that some of the cells I want to extract the data from are empty. Is there a away to tell the macro to write "x" if the there's no data in the cell? I'm thinking of something along the lines of IF(C3=" ", "x" , C3) but I don't know how to translate that into VBA.

Thank you!

 

[HighAndWilder]

Change this line : WsDestination.Cells(lngNextRow, rngTarget.Cells(1, intLoop).Column).Value = rng.Value

to these lines:

If Len(Trim(rng.Value)) = 0 Then
WsDestination.Cells(lngNextRow, rngTarget.Cells(1, intLoop).Column).Value = "x"
Else
WsDestination.Cells(lngNextRow, rngTarget.Cells(1, intLoop).Column).Value = rng.Val
End If

The IF(C3=" ", "x" , C3) method would be used in a cell.

 

[CutterSoilMixing]

Change this line : WsDestination.Cells(lngNextRow, rngTarget.Cells(1, intLoop).Column).Value = rng.Value

to these lines:

If Len(Trim(rng.Value)) = 0 Then
WsDestination.Cells(lngNextRow, rngTarget.Cells(1, intLoop).Column).Value = "x"
Else
WsDestination.Cells(lngNextRow, rngTarget.Cells(1, intLoop).Column).Value = rng.Val
End If

The IF(C3=" ", "x" , C3) method would be used in a cell.

What a legend you are! Works perfectly, thank you so much!