VBA to copy data from multiple workbooks into master sheet

[bhalbach]

I had an extra space in one of the lines. Try:

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?

 

[mumps]

Try:

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]

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?

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

 

[mumps]

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]

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]

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]

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 Name	Project 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.xlsm	2020 Caswell Hill Water Main & Roadway Improvements	COSe21-0002	4.37	Concrete Curb	lin.m	1333​	245​	326585​
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm	2020 Caswell Hill Water Main & Roadway Improvements	COSe21-0002	4.38	Concrete Sidewalk	sq.m	2321​	290​	673090​
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm	2020 Caswell Hill Water Main & Roadway Improvements	COSe21-0002	4.39	Trip Saw Cut	lin.m	86​	140​	12040​
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm	2020 Caswell Hill Water Main & Roadway Improvements	COSe21-0002	4.4	Crack Fill	lin.m	194​	125​	24250​
Estimate - COSe21-0002 Caswell Hill Water Main & Roadway Improvements.xlsm	2020 Caswell Hill Water Main & Roadway Improvements	COSe21-0002	4.41	Concrete Overlay	sq.m	93​	185​	17205​

 

[mumps]

Try:

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]

Try:

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:

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.

Dropbox - File Deleted - Simplify your life

www.dropbox.com

 

[mumps]

Please upload a couple of the source files.