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

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

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("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource.Sheets("appendix B")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("C6:F" & LastRow).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0)
            wsDest.Cells(wsDest.Rows.Count, "G").End(xlUp).Offset(1, 0).Resize(LastRow - 5) = wkbSource.Name
        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
Not quite sure what it is doing.... it seems to be copying all the rows from Data regardless if they have data on them. The range D2:I is a dynamic range and may not have all rows with values in them.
The file name is going to all the copied rows except for the last 3...see attached screen shot.
I changed the code a bit to get the columns i need.

This is what I would like...a bit of a change I added as well.
Copy values (text and numbers) from D3:I and last row from "Data" on all the workbooks in the specified location.
Column I has formulas, but I only need the values....no formatting, formulas etc from any of the columns/rows on "Data".
Paste copied values from "Data" to "Master" sheet starting in Column C2
Copy B2 from Sheet "Info" to same rows of the copied values from "Data", paste B2 Info into "Master" Column B2
Input File name on "Master" to the same rows as the copied values from "Data", paste file name into "Master" Column A2

This is the code I changed the ranges on a bit.

Can you assist me with these requirements?



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 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("D3:I" & LastRow).Copy wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1, 0)
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 5) = wkbSource.Name
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 

Attachments

  • Screenshot 2021-04-28 123044.jpg
    Screenshot 2021-04-28 123044.jpg
    128.2 KB · Views: 9

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624
It's hard to work with a picture. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your "Data" sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 

bhalbach

Board Regular
Joined
Mar 15, 2018
Messages
151
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Maybe a better explanation. I didn't explain clearly before.

I have 2 sheets to extract from multiple workbooks in a file folder.
Sheet "Info"
Sheet "Data"

Put the results on a "Master" sheet in new workbook. Results as below.

Master Sheet to be comprised of the following...starting on row 2.
Filename to "Master "A"
Copy from "Info "B2" to "Master "B"
Copy from "Info B3" to "Master "C"
Copy from "Data D & lastRow" to "Master "D"
Copy from "Data "E" to "Master "E"
Copy from "Data "F" to "Master "F"
Copy from "Data "G" to "Master "G"
Copy from "Data "H" to "Master "H"
Copy from "Data "I" to "Master "I"

Once the first workbook is completed, move to the next workbook and do the same. This data to be placed in the next available row of "Master"

Just the data copy is good, no formatting of any kind.

Thanks for the help.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624
From the first workbook, I assume you want "Info B2" to "Master "B2" and "Info B3" to "Master "C3". Is this correct? Where do you want to paste "Info B2" and "Info B3" from each of the remaining workbooks? From the first workbook, you want "Data D & lastRow" to "Master "D" starting at D2. Is this correct? You want "Data E & lastrow" to "Master E2" and the same for F:I. Is this correct? It would be helpful if you attached a screenshot (not a picture) of your "Data" sheet or uploaded a copy of your file to a free site as I suggested in Post #97.
 

bhalbach

Board Regular
Joined
Mar 15, 2018
Messages
151
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

I am having an issue getting signed into Dropbox.

For the first workbook...
Info B2 goes to Master B2
Info B3 goes to Master C2
These 2 lines need to repeat for every row copied from Data.

From the first workbook, you want "Data D & lastRow" to "Master "D" starting at D2. Is this correct? Yes the copy from Data starts at D3
You want "Data E & lastrow" to "Master E2" and the same for F:I. Is this correct? Yes the copy from Data starts at E3, F3, G3, H3, I3


So...the 1st workbook copied to master would look like this. Not sure if you can see this table correctly or not? (File name is in A1)

File NameProject Name "from Info B2 of each workbook"Contract Number "from Info B3 of each workbook"Bid Item "from Data D3 of each workbook"Bid Item Description "from Data E3 of each workbook"UOM "from Data F3 of each workbook"Units "from Data G3 of each workbook"Bid Rate 'from Data H3 of each workbook"Extension "from Data I3 of each workbook"
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm2020 Caswell Hill Water Main & Roadway ImprovementsCOSe21-00024.37Concrete Curblin.m
1333​
245​
326585​
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm2020 Caswell Hill Water Main & Roadway ImprovementsCOSe21-00024.38Concrete Sidewalksq.m
2321​
290​
673090​
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm2020 Caswell Hill Water Main & Roadway ImprovementsCOSe21-00024.39Trip Saw Cutlin.m
86​
140​
12040​
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm2020 Caswell Hill Water Main & Roadway ImprovementsCOSe21-00024.4Crack Filllin.m
194​
125​
24250​
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm2020 Caswell Hill Water Main & Roadway ImprovementsCOSe21-00024.41Concrete Overlaysq.m
93​
185​
17205​
 
Last edited:

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)
        With wkbSource.Sheets("Data")
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).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 = Sheets("Info").Range("B2").Value
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = 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 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).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 = Sheets("Info").Range("B2").Value
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = Sheets("Info").Range("B3").Value
            End With
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

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 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).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 = Sheets("Info").Range("B2").Value
                .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = Sheets("Info").Range("B3").Value
            End With
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
I is not quite extracting and pasting correctly. I have attached a link to the result that the macro did on 3 workbooks. Not sure If I did the link tot dropbox correctly.

The copy from the "Data" sheet seems correct, but the data from "Info" is not correlating to the proper lines from each workbook. I have added comments in column K:M on the sheet in blue text.

 

Forum statistics

Threads
1,141,818
Messages
5,708,763
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