Macro for copying cells from multiple workbooks

[Moeen]

I am new to this forum and I would be very thankful if anyone can help me out.
I need a code that will copy certain cells from all sheets of all files in a folder and then list/paste them down in another master/summary sheet.
All workbooks in the folder have multiple sheets and in each sheet the cells which I want to copy are A2. B2 and C2
Example :
In work -Book1
Sheet 1

	A	B	C
1	CODE	PAGE	BALANCE
2	47401	ABC-1	12345678

<tbody>
</tbody>

Sheet 2

	A	B	C
1	CODE	PAGE	BALANCE
2	47402	ABC-2	51354351

<tbody>
</tbody>

Sheet 3

	A	B	C
1	CODE	PAGE	BALANCE
2	47403	ABC-3	54542545

<tbody>
</tbody>

In work Book-2
Sheet 1

	A	B	C
1	CODE	PAGE	BALANCE
2	37601	xyz-1	12345678

<tbody>
</tbody>

Sheet 2

	A	B	C
1	CODE	PAGE	BALANCE
2	37602	xyz-2	51354351

<tbody>
</tbody>

Sheet 3

	A	B	C
1	CODE	PAGE	BALANCE
2	37603	xyz-3	54542545

<tbody>
</tbody>

And so on.
I want to compile the highlighted cells in the following format in the summary file.

	A	B	C
1	CODE	PAGE	BALANCE
2	47401	ABC-1	12,345,678
3	47402	ABC-2	51,354,351
4	47403	ABC-3	54,542,545
5	37601	xyz-1	12,345,678
6	37601	xyz-2	51,354,351
7	37603	xyz-3	54,542,545

<tbody>
</tbody>

Any help would be appreciated. I have searched the internet for this and have found the following links but I wasn’t able to make them work.
http://www.mrexcel.com/forum/excel-questions/673353-macro-copy-data-multiple-excel-files.html
http://www.mrexcel.com/forum/excel-questions/508186-loop-through-folder-run-macro-all-workbooks.html
The following code does what I want for 1 workbook only
Sub Button10_Click()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Select
'Sub CopyData()
With ActiveSheet

.Range("A2").Select
Selection.Copy
Sheets("Proof Sheet").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
.Range("B2").Select
Selection.Copy
Sheets("Proof Sheet").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
.Range("C2").Select
Selection.Copy
Sheets("Proof Sheet").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

End With
Application.ScreenUpdating = False
Next
Application.ScreenUpdating = False
Sheets("Proof Sheet").Select
End Sub

I can provide futher details if needed

thanks in advance

 

[hippiehacker]

this should do

Sub MergeAllWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    
    ' Set summarysheet to activeworkbook/activesheet where the macro runs
    Set SummarySheet = ActiveWorkbook.ActiveSheet
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Temp\exceltest\"
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "*.xl*")
    
    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)

        'loop through all Sheets in WorkBk
        For Each sh In WorkBk.Worksheets
          
        ' Set the source range to be A9 through C9.
          Set SourceRange = Sheets(sh.Name).Range("A2:C2")
        
        ' Set the destination range to start at column B and
        ' be the same size as the source range.
        Set DestRange = SummarySheet.Range("A" & SummarySheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
        
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        Next sh
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    ActiveSheet.Columns.AutoFit
End Sub

 

[sb540]

HI I have a similar issue.
I am wanting to copy cells/columns from 1 workbook to another using similar principles and on a weekly basis. However the workbook I am copying data from will have a different name each week. Is there anything I could put to say use workbooks that are open or something else?

Thanks in advance!

 

[hippiehacker]

HI I have a similar issue.
I am wanting to copy cells/columns from 1 workbook to another using similar principles and on a weekly basis. However the workbook I am copying data from will have a different name each week. Is there anything I could put to say use workbooks that are open or something else?

Thanks in advance!

you should open your own thread here an example to loop through all workbook that are open

Sub WBLoop()
    Dim wbk As Workbook, rngToCopy As Range, rngToPaste As Range
     
    With Worksheets("Sheet1")
        For Each wbk In Workbooks
            'loop through the Open workbooks
            If wbk.Name <> ThisWorkbook.Name Then
                'exclude this workbook from the Loop
                Set rngToPaste = .Range("A65536").End(xlUp).Offset(1, 0)
                'set the target For the paste
                Set rngToCopy = wbk.Range("A1:H10")
                'set the range To be copied
                rngToCopy.Copy Destination:=rngToPaste
                'do the copying
            End If
        Next
    End With
     
End Sub

 

[sb540]

Great thanks for the example hippiehacker

 

[Moeen]

I cannot thankyou enough. bless your soul.

Is there anyway to modify the code so that it, instead of pasting the values, it pastes links to the original values. like the pastespecial > paste as links.

I tried to do it myself but i failed
this is what I did, i replaced your ;

"DestRange.Value = SourceRange.Value"

with this :

SourceRange.Select
Selection.Copy
Application.Goto DestRange.Select
ActiveSheet.Paste Link:=True



and some other similar modifications, all gave errors.

a big thanks in advance for any help you will give.

 

[justclickinbuttons]

this should do

Sub MergeAllWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    
    ' Set summarysheet to activeworkbook/activesheet where the macro runs
    Set SummarySheet = ActiveWorkbook.ActiveSheet
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Temp\exceltest\"
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "*.xl*")
    
    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)

        'loop through all Sheets in WorkBk
        For Each sh In WorkBk.Worksheets
          
        ' Set the source range to be A9 through C9.
          Set SourceRange = Sheets(sh.Name).Range("A2:C2")
        
        ' Set the destination range to start at column B and
        ' be the same size as the source range.
        Set DestRange = SummarySheet.Range("A" & SummarySheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
        
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        Next sh
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    ActiveSheet.Columns.AutoFit
End Sub

I'm using this code as a template and it's nearly working. I need it to copy cells (D3,D4,D5,D6,D7,D8,K7,R3,A19:T26) from each sheet and put them into the main workbook moving across until it moves to the next sheet and then start a new row until it has worked through all the files. It's currently putting everything down the first column and I'm getting a subscript error when I try to put this range in.

Thanks for any help I can get, it seems like I'm really close, but I'm very new to VBA so it's taking forever to troubleshoot something that is probably very easy for a lot of you.