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

H

harborman1995

New Member
Joined
May 22, 2018
Messages
4
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:

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
 
Last edited by a moderator:

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Hi & welcome to MrExcel
You're missing an End With
Code: 
   With Selection.Font
      .Name = "Arial"
      .size = 10
 [COLOR=#ff0000]  End With[/COLOR]
'*****End of copy/paste section*****
 
Last edited:
Upvote 0
Step through the code using F8 to see where it crashes.
 
Upvote 0
Is the "Resource" sheet protected?
 
Upvote 0
Hey there,
I have a code which may be what you are looking for. This code will have you select a folder and it will search through every file in that folder and subfolders and subfolders of subfolders for excel files. Once it does this, it will copy and paste data from a given cell into columns for you.

Code: 
Sub GatherData()Range("A1").Value = "Title 1"
Range("B1").Value = "Title 2"          'these are the titles of each piece of data
Range("C1").Value = "Title 3"
Range("D1").Value = "Title 4"


Call PasteLinks
    Dim wbTarget As Workbook
    Dim ary(3) As Variant
    Dim lRow As Long
    Dim CodeNames As Variant, i As Long


CodeNames = Range("Z2:Z" & Cells(Rows.Count, "Z").End(xlUp).Row)
Application.ScreenUpdating = False
For i = 1 To UBound(CodeNames, 1)
    If InStr(1, CodeNames(i, 1), ".xls") > 0 Then
    On Error GoTo linemarker3
        If Not WorkbookOpen(CStr(Split(CodeNames(i, 1), "\")(UBound(Split(CodeNames(i, 1), "\"))))) Then
            Set wbTarget = Workbooks.Open(CodeNames(i, 1))
            
            
              For Each Sheet In wbTarget.Sheets
      If Sheet.Name = "Quote" Then
         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("Quote")
                ary(0) = .Range("B7")
                ary(1) = .Range("B8")
                ary(2) = .Range("B11")
                ary(3) = .Range("B13")                                    'here you can choose what data you want copied. Add or remove these as suits you
            End With
        Else
            Set wbTarget = Workbooks(CStr(Split(CodeNames(i, 1), "\")(UBound(Split(CodeNames(i, 1), "\")))))
            With wbTarget.Worksheets("Quote")
                ary(0) = .Range("B7")
                ary(1) = .Range("B8")
                ary(2) = .Range("B11")
                ary(3) = .Range("B13")
            End With
        End If
        With ThisWorkbook.Worksheets(1)
            lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
            .Range("A" & lRow & ":D" & lRow) = ary                                                'this is pasting the copied data into specified cells in the main workbook
        End With
linemarker2:         With ThisWorkbook.Worksheets(1)
         .Range("Z1").Value = "0"                                      
         End With
        wbTarget.Close SaveChanges:=False
linemarker3:    End If
Next i
Application.ScreenUpdating = True
    Columns("Z:Z").Select                              'this clears the hyperlinks
    Selection.ClearContents
    Range("A1").Select
End Sub
Function WorkbookOpen(WorkBookName As String) As Boolean
    WorkbookOpen = False
    On Error GoTo WorkBookNotOpen
    If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
        WorkbookOpen = True
        Exit Function
    End If
WorkBookNotOpen:
End Function
Sub PasteLinks()                           'this pastes hyperlinks of every file into column z which is used by the macro. It is cleared at the end of it all


  Dim FileSystem As Object
  Dim HostFolder As String


    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder..."
        .Show
        If .SelectedItems.Count > 0 Then
            HostFolder = .SelectedItems(1) & "\"
    End If
    End With
  Set FileSystem = CreateObject("Scripting.FileSystemObject")
  DoFolder FileSystem.getfolder(HostFolder)


End Sub


Sub DoFolder(Folder)                             'this ensures subfolders are looked at


  Dim SubFolder
  For Each SubFolder In Folder.Subfolders
    DoFolder SubFolder
  Next


  i = Cells(Rows.Count, 26).End(xlUp).Row + 1
  Dim File
  For Each File In Folder.files
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 26), Address:= _
        File.Path, TextToDisplay:=File.Path
    i = i + 1


  Next


End Sub

Hope this helps :)
 
Upvote 0
What is the exact error message that you get?
 
Upvote 0
Joe9238 said:
Hey there,
I have a code which may be what you are looking for. This code will have you select a folder and it will search through every file in that folder and subfolders and subfolders of subfolders for excel files. Once it does this, it will copy and paste data from a given cell into columns for you.

Code: 
Sub GatherData()Range("A1").Value = "Title 1"
Range("B1").Value = "Title 2"          'these are the titles of each piece of data
Range("C1").Value = "Title 3"
Range("D1").Value = "Title 4"


Call PasteLinks
    Dim wbTarget As Workbook
    Dim ary(3) As Variant
    Dim lRow As Long
    Dim CodeNames As Variant, i As Long


CodeNames = Range("Z2:Z" & Cells(Rows.Count, "Z").End(xlUp).Row)
Application.ScreenUpdating = False
For i = 1 To UBound(CodeNames, 1)
    If InStr(1, CodeNames(i, 1), ".xls") > 0 Then
    On Error GoTo linemarker3
        If Not WorkbookOpen(CStr(Split(CodeNames(i, 1), "\")(UBound(Split(CodeNames(i, 1), "\"))))) Then
            Set wbTarget = Workbooks.Open(CodeNames(i, 1))
            
            
              For Each Sheet In wbTarget.Sheets
      If Sheet.Name = "Quote" Then
         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("Quote")
                ary(0) = .Range("B7")
                ary(1) = .Range("B8")
                ary(2) = .Range("B11")
                ary(3) = .Range("B13")                                    'here you can choose what data you want copied. Add or remove these as suits you
            End With
        Else
            Set wbTarget = Workbooks(CStr(Split(CodeNames(i, 1), "\")(UBound(Split(CodeNames(i, 1), "\")))))
            With wbTarget.Worksheets("Quote")
                ary(0) = .Range("B7")
                ary(1) = .Range("B8")
                ary(2) = .Range("B11")
                ary(3) = .Range("B13")
            End With
        End If
        With ThisWorkbook.Worksheets(1)
            lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
            .Range("A" & lRow & ":D" & lRow) = ary                                                'this is pasting the copied data into specified cells in the main workbook
        End With
linemarker2:         With ThisWorkbook.Worksheets(1)
         .Range("Z1").Value = "0"                                      
         End With
        wbTarget.Close SaveChanges:=False
linemarker3:    End If
Next i
Application.ScreenUpdating = True
    Columns("Z:Z").Select                              'this clears the hyperlinks
    Selection.ClearContents
    Range("A1").Select
End Sub
Function WorkbookOpen(WorkBookName As String) As Boolean
    WorkbookOpen = False
    On Error GoTo WorkBookNotOpen
    If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
        WorkbookOpen = True
        Exit Function
    End If
WorkBookNotOpen:
End Function
Sub PasteLinks()                           'this pastes hyperlinks of every file into column z which is used by the macro. It is cleared at the end of it all


  Dim FileSystem As Object
  Dim HostFolder As String


    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder..."
        .Show
        If .SelectedItems.Count > 0 Then
            HostFolder = .SelectedItems(1) & "\"
    End If
    End With
  Set FileSystem = CreateObject("Scripting.FileSystemObject")
  DoFolder FileSystem.getfolder(HostFolder)


End Sub


Sub DoFolder(Folder)                             'this ensures subfolders are looked at


  Dim SubFolder
  For Each SubFolder In Folder.Subfolders
    DoFolder SubFolder
  Next


  i = Cells(Rows.Count, 26).End(xlUp).Row + 1
  Dim File
  For Each File In Folder.files
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 26), Address:= _
        File.Path, TextToDisplay:=File.Path
    i = i + 1


  Next


End Sub

Hope this helps :)
Click to expand...

Hi Joe,

I am using your code to copy data from workbooks in a folder. It is working really well, until I tried to add a new data field to copy further data. I have tried to add ary(4) = .Range("F10") but I get an 'out of range' error message. Please see below code.

Code: 
Sub 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"


Call PasteLinks
    Dim wbTarget As Workbook
    Dim ary(3) As Variant
    Dim lRow As Long
    Dim CodeNames As Variant, i As Long


CodeNames = Range("Z2:Z" & Cells(Rows.Count, "Z").End(xlUp).Row)
Application.ScreenUpdating = False
For i = 1 To UBound(CodeNames, 1)
    If InStr(1, CodeNames(i, 1), ".xls") > 0 Then
    On Error GoTo linemarker3
        If Not WorkbookOpen(CStr(Split(CodeNames(i, 1), "")(UBound(Split(CodeNames(i, 1), ""))))) Then
            Set wbTarget = Workbooks.Open(CodeNames(i, 1))
            
            
              For Each Sheet In wbTarget.Sheets
      If Sheet.Name = "Quote" Then
         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("Quote")
                ary(0) = .Range("B34")
                ary(1) = .Range("C34")
                ary(2) = .Range("B40")
                ary(3) = .Range("B39")
                ary(4) = .Range("F10")                        'here you can choose what data you want copied. Add or remove these as suits you
            End With
        Else
            Set wbTarget = Workbooks(CStr(Split(CodeNames(i, 1), "")(UBound(Split(CodeNames(i, 1), "")))))
            With wbTarget.Worksheets("Quote")
                ary(0) = .Range("B34")
                ary(1) = .Range("C34")
                ary(2) = .Range("B40")
                ary(3) = .Range("B39")
                ary(4) = .Range("F10")
            End With
        End If
        With ThisWorkbook.Worksheets(1)
            lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
            .Range("A" & lRow & ":D" & lRow) = ary                                                'this is pasting the copied data into specified cells in the main workbook
        End With
linemarker2:         With ThisWorkbook.Worksheets(1)
         .Range("Z1").Value = "0"
         End With
        wbTarget.Close SaveChanges:=False
linemarker3:    End If
Next i
Application.ScreenUpdating = True
    Columns("Z:Z").Select                              'this clears the hyperlinks
    Selection.ClearContents
    Range("A1").Select
End Sub
Function WorkbookOpen(WorkBookName As String) As Boolean
    WorkbookOpen = False
    On Error GoTo WorkBookNotOpen
    If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
        WorkbookOpen = True
        Exit Function
    End If
WorkBookNotOpen:
End Function
Sub PasteLinks()                           'this pastes hyperlinks of every file into column z which is used by the macro. It is cleared at the end of it all


  Dim FileSystem As Object
  Dim HostFolder As String


    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & ""
        .Title = "Please select a folder..."
        .Show
        If .SelectedItems.Count > 0 Then
            HostFolder = .SelectedItems(1) & ""
    End If
    End With
  Set FileSystem = CreateObject("Scripting.FileSystemObject")
  DoFolder FileSystem.getfolder(HostFolder)


End Sub


Sub DoFolder(Folder)                             'this ensures subfolders are looked at


  Dim SubFolder
  For Each SubFolder In Folder.Subfolders
    DoFolder SubFolder
  Next


  i = Cells(Rows.Count, 26).End(xlUp).Row + 1
  Dim File
  For Each File In Folder.Files
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 26), Address:= _
        File.Path, TextToDisplay:=File.Path
    i = i + 1


  Next


End Sub

I think I haven't defined the range properly. Are you able to help? Any assistance you can provide is very much appreciated.

Thanks,

Patrick
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
VBA - Save each sheet as new workbook with sheet name ( choose all sheets file from a folder & save the extracted workbooks in a folder )
Replies
9
Views
866
ceasar47
C
E
  • Question
Macro to Pull Summary from Multiple Files
Replies
2
Views
245
dreid1011
dreid1011
R
  • Solved
Incorporating my VBA code (that saves all sheets from an excel workbook to CSV) into a looping VBA program (just have myself stumped!)
Replies
3
Views
936
Anthony47
A
G
  • Question
Open workbooks in folder and run Macro in each book
Replies
7
Views
364
glynn1969
G
D
  • Solved
Copying file path from a cell?
Replies
2
Views
229
Dave_george
D

Forum statistics

Threads
1,214,986
Messages
6,122,611
Members
449,090
Latest member
vivek chauhan

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top