Copying from multiple excel workbooks and pasting into another separate "summary" workbook

[harborman1995]

Hi all,

I am trying to build an excel macro. This macro will be executed upon the click of a button.

When the macro is activated, it loops through a folder and performs the same operation on each excel file in the folder. The code between 'Start of File Copy Actions' and 'End of file copy actions' is the code which will be executed upon each file. Rather than have the macro identify cells by Cell Address, I am having it identify by the values in the cell.

You can see in the code that a workbook section is being copied from cell "E34" and copies everything to the cell above "

When I run this it is giving me an error saying the Loop at the bottom was created without a "do".

Can someone help me figure this out?

--
Code:

Sub Get_Finance()
'PURPOSE: To loop through all Excel files in the project folder and retrieve the necessary financial information


Dim Source_Workbooks As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog


'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual


'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)


    With FldrPicker
      .Title = "Select the project folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & ""
    End With


'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings


'Target File Extension (must include wildcard "*")
  myExtension = "*.xlsm*"


'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)


'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set Source_Workbooks = Workbooks.Open(Filename:=myPath & myFile)


    'Ensure Workbook has opened before moving on to next line of code
      DoEvents
    
    'Opens the Resource Sheet
    Sheets("Resource").Select
      
'START OF FILE COPY ACTIONS


    '*****Start of copy/paste section*****
    
        'Sets the Roles / Key Expenses section of OpEx-Build as a variable (And accounts for added rows)
        Dim OpExBuild_RKE As Variant
    
        Range("E34").Select
        Do Until ActiveCell.Value = "Total Implementation OpEx"
            ActiveCell.Range("A1").Offset(1, 0).Select
        Loop
        ActiveCell.Range("A1").Offset(-1, 0).Select
        OpExBuild_RKE = ActiveCell.Address
    
        'Copies the section
        Range("E34", OpExBuild_RKE).Copy
    
        'Opens the Analysis Master file
        Windows("Analysis_Master.xlsm").Activate
        
        'Opens the Finance Master tab within the Analysis Master file
        Sheets("Finance Master").Activate
        
        'Selects the desired paste column of Finance tab
        'Checks the Range and selects the first empty row it finds
        Range("D3").End(xlUp).Offset(1, 0).Select
    
        'Pastes the copied information into the appropriate column
        ActiveSheet.Paste
        
        'Maintains consistent formatting
        With Selection.Font
        .Name = "Arial"
        .Size = 10
    
    '*****End of copy/paste section*****
    
    
'END OF FILE COPY ACTIONS


    'Save and Close Workbook (needed?)
    'Source_Workbook.Close SaveChanges:=True


    'Ensure Workbook has closed before moving on to next line of code
      DoEvents


    'Get next file name
      myFile = Dir
  Loop


'Message Box when tasks are completed
  MsgBox "Financials Retrieved!"


ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub

 

[Joe9238]

.

 

[Joe9238]

o

 

[Joe9238]

Use this. It works slightly better and will do subfolders properly. Remember to change the sheet names as appropriate, the rest has been done for you.

 Option ExplicitSub GatherData()
Range("A1").Value = "First Name"
Range("B1").Value = "Surname"          'these are the titles of each piece of data
Range("C1").Value = "Email Address"
Range("D1").Value = "Phone Number"
Range("E1").Value = "TB Number"
    Dim sFolder As String


    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder..."
        .Show
        If .SelectedItems.Count > 0 Then
            sFolder = .SelectedItems(1) & "\"
    End If
    End With
    
    Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(strFolder As String, wbMaster As Workbook)
Application.ScreenUpdating = False
    Dim wbTarget As Workbook
    Dim objFso As Object
    Dim objFiles As Object
    Dim objSubFolder As Object
    Dim objSubFolders As Object
    Dim objFile As Object
    Dim ary(4) As Variant
    Dim lRow As Long


    'Create objects to enumerate files and folders
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFso.getfolder(strFolder).Files
    Set objSubFolders = objFso.getfolder(strFolder).Subfolders


    'Loop through each file in the folder
    For Each objFile In objFiles
    On Error GoTo linemarker3
        If InStr(1, objFile.Path, ".xls") > 0 Then 'change the file type if needed but this will do all workbooks
        Application.AskToUpdateLinks = False
        Application.DisplayAlerts = False
            Set wbTarget = Workbooks.Open(objFile.Path)
            Dim sheet As Variant
            Set sheet = wbTarget.Sheets
            
            For Each sheet In wbTarget.Sheets
      If sheet.Name = "QUOTE" Then                  'change the sheetname as appropriate
         With ThisWorkbook.Worksheets(1)
         .Range("Z1").Value = "1"
         End With
         Exit For
      End If
   Next sheet
                  With ThisWorkbook.Worksheets(1)
         If .Range("Z1").Value = "1" Then GoTo linemarker1 Else GoTo linemarker2
         End With
            
linemarker1: With ThisWorkbook.Worksheets(1)
         .Range("Z1").Value = "0"
         End With
         
            With wbTarget.Worksheets("Sheet1") 'change the sheetname as appropriate or put 1 for the first sheet from the left and 2 for the second and so on
                ary(0) = .Range("B34")
                ary(1) = .Range("C34")
                ary(2) = .Range("B40")
                ary(3) = .Range("B39")
                ary(4) = .Range("F10")       'add ary(4) if needed but change the line "Dim ary(3) As Variant" at the top
            End With
        If ary(0) = "" Then ary(0) = "Info Not Found"
        If ary(1) = "" Then ary(1) = "Info Not Found"
        If ary(2) = "" Then ary(2) = "Info Not Found"
        If ary(3) = "" Then ary(3) = "Info Not Found"
        If ary(4) = "" Then ary(4) = "Info Not Found"
            With wbMaster.Worksheets(1)
                lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
                .Range("A" & lRow & ":E" & lRow) = ary  'change based on the number of values
            End With
linemarker2: With ThisWorkbook.Worksheets(1)
         .Range("Z1").Value = "0"
         End With
            wbTarget.Close savechanges:=False
        End If
linemarker3:    Next objFile
    'now for the subfolders subfolders
    For Each objSubFolder In objSubFolders
    On Error Resume Next
        Consolidate objSubFolder.Path, wbMaster
        Next objSubFolder


    'Clean up
    Set objFile = Nothing
    Set objFiles = Nothing
    Set objFso = Nothing
            Application.DisplayAlerts = True
            Application.AskToUpdateLinks = True
End Sub

What you had to do was change Dim ary(3) As Variant to Dim ary(4) As Variant.

 

[Padthelad]

Thank you Joe, works a treat!

I wish I had the skill of someone like you with VBA.

Thanks again.

 

[Joe9238]

No problem. I just want to mention that I am relatively terrible at vba; this code was the result of about 3 weeks using google and a hell of a lot of attempts at different methods. I'm happy that this has helped you as well as myself. I know personally how hard it can be to make something complex when knowing nothing about vba.