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

 

[Alex Blakenburg]

I already found code that works perfect for this part.

I know you are referring to this: VBA to copy data from multiple workbooks into master sheet
But please use the actual code you are using (and use the VBA tag in the toolbar) and then we can modify if acordingly.

Do you want the workbook name to the left or right of what is being pasted in ?
Do you want the xlsx or whatever the extension is as part of the workbook name or just the name ?

 

[SunshineVBA]

I know you are referring to this: VBA to copy data from multiple workbooks into master sheet

But please use the actual code you are using (and use the VBA tag in the toolbar) and then we can modify if acordingly.

Do you want the workbook name to the left or right of what is being pasted in ?
Do you want the xlsx or whatever the extension is as part of the workbook name or just the name ?

Below is the code I’m using that I got from the other thread. This is working perfect for putting the range I need into columns B and C in the main workbook. I’d ideally like to put the name of the file in column A beside all data that came from that file.

As for the tag, I’m unsure how to do that. Will try and figure it out.

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\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
.Sheets("CoverPage”).Range(“A14:B” & LastRow).Copy wkbDest.Sheets("AllAcxounts").Cells(Rows.Count, "B”).End(xlUp).Offset(1, 0)
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

As for the tag, I’m unsure how to do that.

Just click on the VBA button in the toolbar and paste the code between code tages that appear.

See if the below works for you.

    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

 

[SunshineVBA]

Just click on the VBA button in the toolbar and paste the code between code tages that appear.

See if the below works for you.

    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

I am getting a runtime (1004) error on line

WkbDest.sheets(“AllAccounts”).Range(Cells(destNextRow, “A”, Cells(destLastTow, “A”)),Value = wkbSource.Name

 

[Alex Blakenburg]

I am unable to replicate that please click on the "VBA" button in the toolbar and paste your full code at the insertion point being between "]" & "[".

 

[Fluff]

As for the tag, I’m unsure how to do that. Will try and figure it out.

Have a look here How to Post Your VBA Code

How about

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

 

[SunshineVBA]

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...\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

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

.Close savechanges:=False

End With

strExtension = Dir

Loop

Application.ScreenUpdating = True

End Sub

 

[SunshineVBA]

Have a look here How to Post Your VBA Code

How about

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

This doesn’t work for me either, I get a run-time error - Automation error

 

[Alex Blakenburg]

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