VBA to copy data from multiple workbooks into master sheet

bhalbach

Board Regular
Joined
Mar 15, 2018
Messages
151
Office Version
  1. 2016
Platform
  1. Windows
I had an extra space in one of the lines. Try:
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("appendix B").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("appendix B").Range("C6:F" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
Can you modify this code to put the File name beside each extracted row?
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624
Your link takes me to the "sign-in" page. I need a direct link to your files.
 

bhalbach

Board Regular
Joined
Mar 15, 2018
Messages
151
Office Version
  1. 2016
Platform
  1. Windows
Try this....sorry I dont do much of this sharing thing.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624

ADVERTISEMENT

Try:
VBA Code:
Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbSource As Workbook, wsDest As Worksheet, LastRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
    strExtension = Dir("*.xlsm")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource.Sheets("Data")
            LastRow = .Range("D" & Rows.Count).End(xlUp).Row
            .Range("D3:I" & LastRow).Copy
            With wsDest
                .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 2) = wkbSource.Name
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbSource.Sheets("Info").Range("B2").Value
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbSource.Sheets("Info").Range("B3").Value
            End With
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 

bhalbach

Board Regular
Joined
Mar 15, 2018
Messages
151
Office Version
  1. 2016
Platform
  1. Windows
Try:
VBA Code:
Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbSource As Workbook, wsDest As Worksheet, LastRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
    strExtension = Dir("*.xlsm")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource.Sheets("Data")
            LastRow = .Range("D" & Rows.Count).End(xlUp).Row
            .Range("D3:I" & LastRow).Copy
            With wsDest
                .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 2) = wkbSource.Name
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbSource.Sheets("Info").Range("B2").Value
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbSource.Sheets("Info").Range("B3").Value
            End With
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
Seems to work good 👍😁.

I found it errors if one of the named sheets is not found...ie Info or Data sheet not found. Can you put an error handle in for that?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624
Try:
VBA Code:
Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbsource As Workbook, wsDest As Worksheet, LastRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
    strExtension = Dir("*.xlsm")
    Do While strExtension <> ""
        Set wkbsource = Workbooks.Open(strPath & strExtension)
        If Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Data" & "'!$A$1)")) Then
            With wkbsource.Sheets("Data")
                LastRow = .Range("D" & Rows.Count).End(xlUp).Row
                .Range("D3:I" & LastRow).Copy
                With wsDest
                    .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 2) = wkbsource.Name
                    If Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Info" & "'!$A$1)")) Then
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B2").Value
                        .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B3").Value
                    End If
                End With
            End With
        ElseIf Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Info" & "'!$A$1)")) Then
            With wsDest
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 2) = wkbsource.Name
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B2").Value
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B3").Value
            End With
        End If
        wkbsource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 

bhalbach

Board Regular
Joined
Mar 15, 2018
Messages
151
Office Version
  1. 2016
Platform
  1. Windows
Try:
VBA Code:
Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbsource As Workbook, wsDest As Worksheet, LastRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
    strExtension = Dir("*.xlsm")
    Do While strExtension <> ""
        Set wkbsource = Workbooks.Open(strPath & strExtension)
        If Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Data" & "'!$A$1)")) Then
            With wkbsource.Sheets("Data")
                LastRow = .Range("D" & Rows.Count).End(xlUp).Row
                .Range("D3:I" & LastRow).Copy
                With wsDest
                    .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 2) = wkbsource.Name
                    If Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Info" & "'!$A$1)")) Then
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B2").Value
                        .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B3").Value
                    End If
                End With
            End With
        ElseIf Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Info" & "'!$A$1)")) Then
            With wsDest
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 2) = wkbsource.Name
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B2").Value
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B3").Value
            End With
        End If
        wkbsource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
Nice!!!

Thank you so much, you saved me a ton of work. Really appreciate this.
 

Forum statistics

Threads
1,141,816
Messages
5,708,753
Members
421,588
Latest member
Wawie

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
Top