VBA code to combine multiple workbooks and record name

[SunshineVBA]

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

 

[SunshineVBA]

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:

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

With these 3 lines:

            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.

            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

 

[Alex Blakenburg]

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 ?

 

[SunshineVBA]

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

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

 

[Alex Blakenburg]

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:

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

 

[Alex Blakenburg]

Ignore the previous code. I have set up some import files to more closely approximate what you are describing.
Try the code below:

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

 

[SunshineVBA]

Ignore the previous code. I have set up some import files to more closely approximate what you are describing.
Try the code below:

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

 

[Alex Blakenburg]

Thanks for letting me know. Glad I could help.