VBA code to Copy+Paste to master document and loop through multiple Documents

[Commander Vimes]

Hello,

I need help with some VBA coding, my requirement is: I need to copy and paste ranges from 21 excel docs in a folder to a Master workbook within relevant named sheets. I have some code, but want to loop it so it runs through each of the docs and copys+pastes the relevant parts into the relevant sections of the MasterWorkbook

Example:
MasterWorkbook has the below worksheets:
>>INPUT N1
>>INPUT N2
>>INPUT D1
>>INPUT C1

Document 1 of 21 (as do the other 20) has the below sheets:
N1
N2
D1
C1

I have code (see below) to copy range in N1 to reference cell in >>INPUT N1 (Application.Goto Reference:="R601C2") and so on for the other 3. Now I want to loop the code so it repeats the process for the remaining docs and changes the references so that they are correct.

Each doc 1-21 should paste the info into a different section eg
Doc 1 Application.Goto Reference:="R1C2"
Doc 2 Application.Goto Reference:="R101C2"
Doc 3 Application.Goto Reference:="R201C2"
Etc

So how do I get the Code to loop and change the document it opens and the reference it pastes to in the Master Workbook?

So I want the code to
Open doc 1
Copy N1 range
Paste into Master Workbook >>INPUT N1 specified range
Do this for N2, D1,C1 aswell.
Close Doc 1
Repeat process for Doc 2 etc


My current CODE:

 Sub CopyInputSheetData()
'
' CopyInputSheetData Macro
'
 
'
 
    ' Prevents screen refreshing.
    Application.ScreenUpdating = False
 
'Timer Start
Dim i As Integer
 
Dim StartTime As Double
Dim SecondsElapsed As Double
 
  StartTime = Timer
 
 
'*************************************************************************************************
 
'Need to change File location to the correct one files are stored in
    Workbooks.Open Filename:= _
        "file location for Document 1.xlsm"
 
'N1
'This is the copy section to copy N1 from Sheet opened above
    Sheets("N1").Select
    Range("A5").Select
    Selection.CurrentRegion.Select
    Selection.Copy
 
    Windows("MasterWorkbook.xlsm"). _
        Activate
Sheets(">>INPUT N1").Select
    Application.Goto Reference:="R601C2"
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
'N2
Windows("Document 1.xlsm"). _
        Activate
Sheets("N2").Select
    Range("A5").Select
    Selection.CurrentRegion.Select
    Selection.Copy
 Windows("MasterWorkbook.xlsm"). _
        Activate
Sheets(">>INPUT N2").Select
    Application.Goto Reference:="R601C2"
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
'D1
Windows("Document 1.xlsm"). _
        Activate
Sheets("D1").Select
    Range("A5").Select
    Selection.CurrentRegion.Select
    Selection.Copy
 Windows("MasterWorkbook.xlsm"). _
        Activate
Sheets(">>INPUT D1").Select
    Application.Goto Reference:="R601C2"
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
 
'C1
Windows("Document 1.xlsm"). _
        Activate
Sheets("C1").Select
    Range("A5").Select
    Selection.CurrentRegion.Select
    Selection.Copy
 Windows("MasterWorkbook.xlsm"). _
        Activate
Sheets(">>INPUT C1").Select
    Application.Goto Reference:="R601C2"
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
 
Workbooks("Document 1.xlsm").Close
 
'*************************************************************************************************
 
 
 
     ' Enables screen refreshing.
    Application.ScreenUpdating = True
 
  SecondsElapsed = Round(Timer - StartTime, 2)
  MsgBox " Input Sheet Data has now been imported, in " & SecondsElapsed & " seconds", vbInformation
End Sub

 

[Fluff]

Hia
How about

    Dim Wb As Integer
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    Dim MasterWb As Workbook
    Dim sWb As Workbook
    Dim Rw As Long
    Dim Pth As String
    StartTime = Timer
    
    Application.ScreenUpdating = False
  
    Set MasterWb = ThisWorkbook
    Pth = "[COLOR=#0000ff]C:\***[/COLOR]"
    Rw = 1
    For Wb = 1 To 21
        Workbooks.Open Pth & "\Document " & Wb & ".xlsm"
        'N1
        sWb.Sheets("N1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT N1").Range("B" & Rw).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        'N2
        sWb.Sheets("N2").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT N2").Range("B" & Rw).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        'D1
        sWb.Sheets("D1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT D1").Range("B" & Rw).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        'C1
        sWb.Sheets("C1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT C1").Range("B" & Rw).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        sWb.Close
        Rw = Rw + 100
    Next Wb
    
    ' Enables screen refreshing.
    Application.ScreenUpdating = True
    
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox " Input Sheet Data has now been imported, in " & SecondsElapsed & " seconds", vbInformation
End Sub

You'll need to change the bit in blue to the correct path.

 

[Commander Vimes]

Thanks for this Fluff. Looks very neat I can use this.

What if I have named documents - eg Dog.xlsm, Cat.xlsm, Mouse.xlsm.....
And I want the ranges copied to a specified range that is not increasing by 100 each time?

eg
Dog.xlsm N1 copied to MasterWkb >>INPUT N1 range B101
Cat.xlsm N1 copied to MasterWkb >>INPUT N1 range B179
Mouse.xlsm N1 copied to MasterWkb >>INPUT N1 range B247

Could I set this code to run through a list for both and use as the input?

 

[Fluff]

How do you determine which row the data goes in, is it simply the next blank row?

 

[Commander Vimes]

The current layout of docs is pretty much: Input sheets where data is recorded (N1, N2 etc) in name format:

Dog 1.xlsm
Cat 1.xlsm

Where the 1 indicated the month data is captured for (so each month this changes incrementally to indicate a new month) month 1=Dog 1.xlsm, month 2 = Dog 2.xlsm etc

Each input sheet Dog, Cat etc is copied into locations which remain static/same in the relevant Master Workbook sheets:

Dog to B101
Cat to B257
etc

My initial thoughts were whether the code could look at a list of the variables to use within the code? Like the name, number for the doc ref and the specific ref for the doc.

Table
Name Ref | Mnth No | Input Ref
Dog | 1 | B101
Cat | 1 | B257

So > Open Doc Dog 1.xlsm and copy N1 range to B101 in >>INPUT N1
repeat for all other docs in folder using their name ref & Mnth No, and input reference.

 

[Fluff]

How about

    Dim Wb As Range
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    Dim MasterWb As Workbook
    Dim sWb As Workbook
    Dim Rw As Long
    Dim Pth As String
    Dim FileRng As Range
    StartTime = Timer
    
    Application.ScreenUpdating = False
  
    Set MasterWb = ThisWorkbook
    With MasterWb.Sheets("[COLOR=#0000ff]WsNames[/COLOR]")
        Set FileRng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    Pth = "[COLOR=#0000ff]####[/COLOR]"
'    Rw = 1
    For Each Wb In FileRng
        Set sWb = Workbooks.Open(Pth & Wb & " " & Wb.Offset(, 1) & ".xlsm")
        'N1
        sWb.Sheets("N1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT N1").Range(Wb.Offset(, 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        'N2
        sWb.Sheets("N2").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT N2").Range(Wb.Offset(, 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        'D1
        sWb.Sheets("D1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT D1").Range(Wb.Offset(, 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        'C1
        sWb.Sheets("C1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT C1").Range(Wb.Offset(, 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        sWb.Close
    Next Wb
    
    ' Enables screen refreshing.
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox " Input Sheet Data has now been imported, in " & SecondsElapsed & " seconds", vbInformation
End Sub

This is based on having a sheet called WsNames with Dog in column A 1 in B & B101 in C

 

[Commander Vimes]

Awesome, Thanks Fluff!

I created the table and set up to correspond as indicated.

As It was prompting me to save changes and keep or discard clipboard items after the code used each document, I did add in:

Application.DisplayAlerts = False
Application.DisplayAlerts = True
Alongside the
Application.ScreenUpdating = False
Application.ScreenUpdating = True

This seems to have worked and now works a treat, takes approximately 80 seconds to run through and copy in the data from 21 documents. So very useful!

Many thanks again

 

[Fluff]

Glad to have helped & thanks for the feedback.

As It was prompting me to save changes and keep or discard clipboard items after the code used each document

My fault, I had the CutCopyMode in the wrong place & forgot to say false after the workbook close. I have corrected that here

    Dim Wb As Range
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    Dim MasterWb As Workbook
    Dim sWb As Workbook
    Dim Rw As Long
    Dim Pth As String
    Dim FileRng As Range
    StartTime = Timer
    
    Application.ScreenUpdating = False
  
    Set MasterWb = ThisWorkbook
    With MasterWb.Sheets("WsNames")
        Set FileRng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    
    Pth = "####\"
'    Rw = 1
    For Each Wb In FileRng
        Set sWb = Workbooks.Open(Pth & Wb & " " & Wb.Offset(, 1) & ".xlsm")
        'N1
        sWb.Sheets("N1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT N1").Range(Wb.Offset(, 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        'N2
        sWb.Sheets("N2").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT N2").Range(Wb.Offset(, 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        'D1
        sWb.Sheets("D1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT D1").Range(Wb.Offset(, 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        'C1
        sWb.Sheets("C1").Range("A5").CurrentRegion.Copy
        MasterWb.Sheets(">>INPUT C1").Range(Wb.Offset(, 2)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
       [COLOR=#0000ff] Application.CutCopyMode = False[/COLOR]
        sWb.Close [COLOR=#0000ff]False[/COLOR]
    Next Wb
    
    ' Enables screen refreshing.
    Application.ScreenUpdating = True
    
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox " Input Sheet Data has now been imported, in " & SecondsElapsed & " seconds", vbInformation
End Sub

One word of warning with using the DisplayAlerts, is that, if the macro should fai,l the Alerts will still be turned off, so you really need to add an error handler to the code in order to reset them

 

[Commander Vimes]

Cheers, thanks i'll update as suggested. Thanks for the warning on the DisplayAlerts too!

 

[Fluff]

Thanks for the warning on the DisplayAlerts too!

No problem