VBA code to combine multiple workbooks and record name

SunshineVBA

New Member
Joined
May 21, 2022
Messages
10
Office Version
  1. 365
Platform
  1. Windows
Hello,

I’m looking for a piece of code that will go through all the files in a folder, copy data from tab “CoverPage” for range at A14:B and down (there could be 1 line or could be up to 15, not consistent). Then paste it into the main workbook and worksheet “Allaccounts”.

So I already found code that works perfect for this part. But I am wanting to also record the name of the source workbook beside any lines of data that it copied. Wondering if anyone can help me with this piece of code?

Thank you
 
At some point you changed (corrected) your sheet name from AllAcxounts to AllAccounts and this is what has caused the error in the previous post using Fluff's more explicit code.
This is just a slight variation of his so replace this line:
VBA Code:
wkbDest.Sheets("AllAccounts").Range(Cells(destNextRow, "A"), Cells(destLastRow, "A")).Value = wkbSource.Name

With these 3 lines:
VBA Code:
            With wkbDest.Sheets("AllAccounts")
                .Range(.Cells(destNextRow, "A"), .Cells(destLastRow, "A")).Value = wkbSource.Name
            End With

Given you are in a different time zone and to keep it moving, if that doesn't work put this before that With wkbDest line and send us a picture of the last time it displays.
VBA Code:
            MsgBox Prompt:="destNextRow: " & destNextRow & vbTab & "destLastRow: " & destLastRow
Yes I Did correct it, I apologize I didn’t specify that that was a typo.

Replacing those lines did not work. So I added the other piece of code as suggested. This is what the pop up says
 

Attachments

  • 741907E2-6084-46E9-8C34-49E3139C9DFF.png
    741907E2-6084-46E9-8C34-49E3139C9DFF.png
    2.8 KB · Views: 3
Upvote 0

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Did you select multiple files ,?
Did the message box appear more than once ? Or was that the very first time ?
Did some files load and if so did they have the name ?
 
Last edited:
Upvote 0
Did you select multiple files ,?
Did the message box appear more than once ? Or was that the very first time ?
Did some files load and if so did they have the name ?
The code is for all the files in a folder, currently I have 4 workbooks in that folder.

Yes I only get 1 pop up, one I hit okay I think get the run-time error ‘2147221070, Automation error

Once I hit end on the error, it pasted the initial columns I wanted but does not post the name

VBA Code:
Sub CopyRange()

    Application.ScreenUpdating = False

    Dim wkbDest As Workbook

    Dim wkbSource As Workbook

    Set wkbDest = ThisWorkbook

    Dim LastRow As Long

    Const strPath As String = "C:\Users\Username\OneDrive - abc\Desktop\Projects\Working Papers\WP from sharepoint\Test\"

    ChDir strPath

    strExtension = Dir("*.xlsb*")

    Do While strExtension <> ""

        Set wkbSource = Workbooks.Open(strPath & strExtension)

        With wkbSource

            LastRow = .Sheets("CoverPage").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

            .Sheets("CoverPage").Range("A14:B" & LastRow).Copy wkbDest.Sheets("AllAccounts").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)

            .Close savechanges:=False

            End With

       

        MsgBox Prompt:="destNextRow: " & destNextRow & vbTab & "destLastRow: " & destLastRow

           

        With wkbDest.Sheets("AllAccounts")

                .Range(.Cells(destNextRow, "A"), .Cells(destLastRow, "A")).Value = wkbSource.Name

            End With

          

        strExtension = Dir

    Loop

    Application.ScreenUpdating = True

End Sub
 
Last edited by a moderator:
Upvote 0
Its good that you posted all your the code or we would have been chasing stuff that wasn't there.
Why are you only using part of the code ?
Please try the full code, if there is an error message send me a picture of the error and the line in the code that is hightlighted.

Please try the entire code:
VBA Code:
Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim LastRow As Long, destNextRow As Long, destLastRow As Long
    Dim strExtension As String
    Set wkbDest = ThisWorkbook
    
    Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            LastRow = .Sheets("CoverPage").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            destNextRow = wkbDest.Sheets("AllAcxounts").Cells(Rows.Count, "B").End(xlUp).Row + 1
            .Sheets("CoverPage").Range("A14:B" & LastRow).Copy wkbDest.Sheets("AllAcxounts").Cells(destNextRow, "B")
            ' Add Source Workbook Name
            destLastRow = wkbDest.Sheets("AllAcxounts").Cells(Rows.Count, "B").End(xlUp).Row
            wkbDest.Sheets("AllAcxounts").Range(Cells(destNextRow, "A"), Cells(destLastRow, "A")).Value = wkbSource.Name
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Ignore the previous code. I have set up some import files to more closely approximate what you are describing.
Try the code below:

VBA Code:
Sub CopyRange()

    Application.ScreenUpdating = False
    
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim LastRow As Long, destNextRow As Long, destLastRow As Long
    Dim strExtension As String
    
    Set wkbDest = ThisWorkbook
    
    Const strPath As String = "C:\Users\amberg\OneDrive - Sobeys\Desktop\Projects\Working Papers\WP from sharepoint\Test\"
    
    ChDir strPath
    strExtension = Dir("*.xlsb*")
    
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        
        With wkbSource
            LastRow = .Sheets("CoverPage").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            destNextRow = wkbDest.Sheets("AllAccounts").Cells(Rows.Count, "B").End(xlUp).Row + 1
            .Sheets("CoverPage").Range("A14:B" & LastRow).Copy wkbDest.Sheets("AllAccounts").Cells(destNextRow, "B")
            ' Add Source Workbook Name
            destLastRow = wkbDest.Sheets("AllAccounts").Cells(Rows.Count, "B").End(xlUp).Row
        End With
        
        With wkbDest.Sheets("AllAccounts")
            .Range(.Cells(destNextRow, "A"), .Cells(destLastRow, "A")).Value = wkbSource.Name
        End With
        
        wkbSource.Close savechanges:=False
        
        strExtension = Dir

    Loop
    
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Solution
Ignore the previous code. I have set up some import files to more closely approximate what you are describing.
Try the code below:

VBA Code:
Sub CopyRange()

    Application.ScreenUpdating = False
   
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim LastRow As Long, destNextRow As Long, destLastRow As Long
    Dim strExtension As String
   
    Set wkbDest = ThisWorkbook
   
    Const strPath As String = "C:\Users\amberg\OneDrive - Sobeys\Desktop\Projects\Working Papers\WP from sharepoint\Test\"
   
    ChDir strPath
    strExtension = Dir("*.xlsb*")
   
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
       
        With wkbSource
            LastRow = .Sheets("CoverPage").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            destNextRow = wkbDest.Sheets("AllAccounts").Cells(Rows.Count, "B").End(xlUp).Row + 1
            .Sheets("CoverPage").Range("A14:B" & LastRow).Copy wkbDest.Sheets("AllAccounts").Cells(destNextRow, "B")
            ' Add Source Workbook Name
            destLastRow = wkbDest.Sheets("AllAccounts").Cells(Rows.Count, "B").End(xlUp).Row
        End With
       
        With wkbDest.Sheets("AllAccounts")
            .Range(.Cells(destNextRow, "A"), .Cells(destLastRow, "A")).Value = wkbSource.Name
        End With
       
        wkbSource.Close savechanges:=False
       
        strExtension = Dir

    Loop
   
    Application.ScreenUpdating = True
   
End Sub
This worked! Thanks so much
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,238
Members
448,555
Latest member
RobertJones1986

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