VBA to copy data from multiple workbooks into master sheet

B

bhalbach

Board Regular
Joined
Mar 15, 2018
Messages
221
Office Version
  1. 2016
Platform
  1. Windows
mumps said:
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
Click to expand...
Can you modify this code to put the File name beside each extracted row?
 
Sort by date Sort by votes

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Your link takes me to the "sign-in" page. I need a direct link to your files.
 
Upvote 0
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
 
Upvote 0
mumps said:
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
Click to expand...
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?
 
Upvote 0
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
 
Upvote 0
mumps said:
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
Click to expand...
Nice!!!

Thank you so much, you saved me a ton of work. Really appreciate this.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA: All Sheets data to Master Sheet (excluding some sheet)
2
Replies
11
Views
390
kevin9999
K
L
  • Solved
Fixing VBA code
Replies
3
Views
484
Joe4
Joe4
S
  • Question
Combine macro
Replies
0
Views
304
SasiKumar007
S
M
  • Question
override a copied columns in summary sheet
Replies
0
Views
331
mlmahajan
M
P
  • Solved
VBA - Copy data between workbooks. Add column with filename and don't copy empty rows
Replies
3
Views
840
mumps
mumps

Forum statistics

Threads
1,214,827
Messages
6,121,803
Members
449,048
Latest member
greyangel23

Share this page

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