VBA to copy data from multiple workbooks into master sheet

[excel_vba_1]

Hello Everyone!

I have to copy data from 10+ workbooks and paste it into a master workbook.
All the workbooks are located in a folder on my desktop: C:\Users\xbv\Desktop\group1

All the workbooks contain a sheet named 'appendix B', I have to open each workbook, go to sheet 'appendix B’, select columns range C to F starting from row 6 to row ‘x'(the last row can vary in each workbook), cntrl+v (copy), and paste the data range into master worksheet. In the master worksheet, I paste the data in Columns A to D and continue pasting/appending the data as I copy data from more workbooks. Eventually, the master workbook has the data in columns A to D from every workbook in one sheet.

The columns range C to F and starting from row 6 always remains constant in all the sheets (appendix B ) of every workbook. Each workbook contains 7 sheets, but I am only interested in sheet ‘appendix B’

I have to repeat the same steps for 10-30 workbooks and continue pasting/appending the data into master sheet. So, I was wondering if someone could please help me to create a VBA code for this? I'm really new to VBA and would really appreciate your help!

Please let me know if you require any clarification.

Many thanks! =)

 

[nurulainifr]

i've done follow the instructions. the instructions said that the macros can be enabled on options and then trust center. after i did that, the code still can't appear the results but it wasn't error. so, what should i did to show the results?:")
thankyou

 

[mumps]

Make sure that all three workbooks are saved in the same folder and try this version of the macro.

Sub CopySheet()
    Application.ScreenUpdating = False
    Dim srcWB As Workbook, desWB As Workbook, strPath As String
    Set desWB = ThisWorkbook
    strPath = desWB.Path & "\"
    ChDir strPath
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With desWB
            Sheets("Sheet1").Copy after:=.Sheets(.Sheets.Count)
            ActiveSheet.UsedRange.Cells.Value = ActiveSheet.UsedRange.Cells.Value
        End With
        srcWB.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Dn Dilf]

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

Hi guys,

I looked at this code and with some minor changes I got almost all the answers I needed, except for one (stupid) thing that I can't seem to fix.
With using the code below I copied and pasted, but I want it to paste it as values. I tried to squueze in a .PasteSpecial x1PasteValues or something but only failure so far.

Can anyone help me?

 

[mumps]

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).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Dn Dilf]

Thanks for the support, that works!
The code doesn't resolve the clipboard messages after copying each range. I thought the Application.CutCopyMode = False would do this?

 

[mumps]

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).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Dn Dilf]

Of course, after every file, not just at the end!
This is 100% for me, thanks for the help!

 

[mumps]

You are very welcome.

 

[LaptopCup]

I'm using a code from the very beginning of this chain, I have it posted below. I am copying specific cells and putting them into a table, so I can manipulate the data. There's around 40 individual cells I plan on copying over, some cells have formulas (which are protected), so I want just the value, therefore I am trying to use:

.Sheets("Summary").Range("E3").Value = wkbDest.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value

This is giving me an error, as the Workbook I am coping from is password protected.


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:\Destination"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
.Sheets("Summary").Range("D3").Copy wkbDest.Sheets("Sheet1").Range("A1")
.Sheets("Summary").Range("E3").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("D4").Copy wkbDest.Sheets("Sheet1").Range("B1")
.Sheets("Summary").Range("E4").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("D5").Copy wkbDest.Sheets("Sheet1").Range("C1")
.Sheets("Summary").Range("E5").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("D7").Copy wkbDest.Sheets("Sheet1").Range("D1")
.Sheets("Summary").Range("E7").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("O3").Copy wkbDest.Sheets("Sheet1").Range("E1")
.Sheets("Summary").Range("P3").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
.Sheets("Summary").Range("O5").Copy wkbDest.Sheets("Sheet1").Range("F1")
.Sheets("Summary").Range("P5").Copy wkbDest.Sheets("Sheet1").Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)


.Close savechanges:=False

'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

 

[mumps]

Is wkbSource (the workbook) password protected or is the "Summary" sheet in wkbSource protected?