Macro to combine and transpose data from several workbooks into one

[ta3991]

Hi,

I have over 400 workbooks that are exactly the same layout but contain different data in each one. I need to combine the data from all of these workbooks into one master spreadsheet.

1. The macro needs to pull the data from specific cells that are the same in each of the 400 workbooks, and paste/transpose them into separate rows on the master spreadsheet.

2. Every sheet is contained within subfolders in the folder "C:\Users\ta3991\Documents\Patch-clamp" on my PC.

3. Every excel sheet that I want to pull data from contains a sheet entitled "Summary data (all cells)".

4. The cells that need to be copied from each of the 400 workbooks are A1, B2:D2, B3:D3, B6:D6

5. The cells should be pasted so all the information from one column in one workbook is a row on the master sheet. I.e.
Workbook 1 cell A1 into P1, B2:D2 into Q2:Q4, B3:D3 into R2:R4, B6:D6 into S2:S4. Workbook 2 cell A1 into P1, B2:D2 into Q5:Q7, B3:D3 into R5:R7, B6:D6 into S5:S7

Etc. (so that cells from columns B-D from the sheet "Summary data (all cells)" from every workbook within "C:\Users\ta3991\Documents\Patch-clamp" is shown paste-transposed as its own row in the master workbook).

6. If its possible, I would also like the name of each of the 400 files to appear in column O on the master workbook alongside the data that has come from that file. I have no idea how to do this bit so I have not included it in my attempt so far.

Any help at all would be greatly appreciated!

Macro attempt so far:

Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim fileName As String
Dim ws As Worksheet
Dim counter As Long


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' Set summarysheet to activeworkbook/activesheet where the macro runs
Set SummarySheet = ActiveWorkbook.ActiveSheet

'Select Folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = "C:\Users\Natasha\Documents\PhD\Patch-clamp"
If .Show = -1 Then
FolderPath = .SelectedItems(1) & ""
Else
Exit Sub 'User Canceled
End If
End With

' Call Dir the first time, pointing it to all Excel files in the folder path.
fileName = Dir(FolderPath & "*.xlsx*")

Application.ScreenUpdating = False
' Loop until Dir returns an empty string.
Do While fileName <> ""
' Open a workbook in the folder
With Workbooks.Open(FolderPath & fileName)

' Set the source worksheet
Set ws = Nothing
On Error Resume Next
Set ws = .Sheets("Summary data (all cells)")
On Error GoTo 0

If Not ws Is Nothing Then

NextRow = SummarySheet.Range("A" & Rows.Count).End(xlUp).Row + 1


' Copy over the values from the source to the destination next row.
ws.Range("A1").Copy
SummarySheet.Range("P1").PasteSpecial Paste:=xlPasteValues, Transpose:=False
ws.Range("B2:D2").Copy
SummarySheet.Range("Q2" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
ws.Range("B3:D3").Copy
SummarySheet.Range("R2" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
ws.Range("B6:D6").Copy
SummarySheet.Range("S2" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True

counter = counter + 1
End If

' Close the source workbook without saving changes.
.Close SaveChanges:=False
End With

' Use Dir to get the next file name.
fileName = Dir()
Loop
Application.ScreenUpdating = True

' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
MsgBox counter & " workbooks consolidated. ", , "Consolidation Complete"

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

 

[cerfani]

does the macro not work? Are you stuck on a certain part?

 

[ta3991]

It doesn't work It runs successfully but no data is pasted into the master spreadsheet so something must be wrong. I think the problem must be in where the macro is looking for the files? But I'm not sure.

 

[cerfani]

Start by debugging the macro, set a breakpoint on the first line of code and then press F8 to step through each line of code 1 by 1 until you see something go awry. I am going to indent your code because it is hard for me to read, it is easier to follow the flow of your code if you use proper indenting. MrExcel forum loses indenting unless you use code tags fyi...

Sub MergeAllWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim fileName As String
    Dim ws As Worksheet
    Dim counter As Long


    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Set summarysheet to activeworkbook/activesheet where the macro runs
    Set SummarySheet = ActiveWorkbook.ActiveSheet

    'Select Folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = "C:\Users\Natasha\Documents\PhD\Patch-clamp"
        If .Show = -1 Then
            FolderPath = .SelectedItems(1) & ""
        Else
            Exit Sub 'User Canceled
        End If
    End With

    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    fileName = Dir(FolderPath & "*.xlsx*")

    Application.ScreenUpdating = False

    ' Loop until Dir returns an empty string.
    Do While fileName <> ""
        ' Open a workbook in the folder
        With Workbooks.Open(FolderPath & fileName)

            ' Set the source worksheet
            Set ws = Nothing
            On Error Resume Next
            Set ws = .Sheets("Summary data (all cells)")
            On Error GoTo 0

            If Not ws Is Nothing Then

                NextRow = SummarySheet.Range("A" & Rows.Count).End(xlUp).Row + 1


                ' Copy over the values from the source to the destination next row.
                ws.Range("A1").Copy
                SummarySheet.Range("P1").PasteSpecial Paste:=xlPasteValues, Transpose:=False
                ws.Range("B2:D2").Copy
                SummarySheet.Range("Q2" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
                ws.Range("B3:D3").Copy
                SummarySheet.Range("R2" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
                ws.Range("B6:D6").Copy
                SummarySheet.Range("S2" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True

                counter = counter + 1
            End If

            ' Close the source workbook without saving changes.
            .Close SaveChanges:=False
        End With

        ' Use Dir to get the next file name.
        fileName = Dir()
    Loop

    Application.ScreenUpdating = True

    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    SummarySheet.Columns.AutoFit
    MsgBox counter & " workbooks consolidated. ", , "Consolidation Complete"

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

 

[cerfani]

This looks weird to me...

SummarySheet.Range("Q2" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True

Do you mean something like this??

SummarySheet.Range("Q2:Q" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True

to reference multiple cells you need to put the top left cell on the left of a colon and bottom right cell on the right of the colon... ex. Q2:Q3

 

[ta3991]

Not quite sure I understand what you mean here, so will "Q2:Q" & NextRow make sure the next data value goes in the next row down in column Q?

Sorry I'm extremely new to this as you may gather.

 

[cerfani]

Tell me what you mean when you put "Q2" & NextRow

If NextRow is some number, then it will append that value after the 2. Let's say NextRow = 3 ... so then you will try to reference Q23 ... "Q2" & "3"

I think you actually meant to reference maybe just Q3... so do ... "Q" & NextRow... then that would result in "Q" & "3" or "Q3"

I have no idea though, you tell me what you were trying to do.

 

[ta3991]

I would like the same cells from each of my workbooks to be pasted and transposed into column Q. So for example I want cells B2:D2 from every workbook to all be pasted into column Q. Does that make sense?

So from workbook 1:
B2 into Q2
C2 into Q3
D2 into Q4

Then from workbook 2 it follows on:
B2 into Q5
C2 into Q6
D2 into Q7

and so on.

I hope that makes sense.

 

[cerfani]

Try changing...

ws.Range("B2:D2").Copy
SummarySheet.Range("Q2" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True

to...

ws.Range("B2:D2").Copy
SummarySheet.Range("Q2:Q" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True

I mentioned earlier... "Q2" & NextRow will not result in what you anticipated... it will simply append the number to the text "Q2"

Also if you are transposing 3 horizontal cells and if you are starting to paste at row 2 then you already know the ending row it will be pasted on (it is row 4) you need to calculate the starting row to paste on

ws.Range("B2:D2").Copy
SummarySheet.Range("Q" StartRow & ":Q" & (StartRow + 2)).PasteSpecial Paste:=xlPasteValues, Transpose:=True

If you wanted to continue down the column, every loop you need to increment StartRow by 3 so you can keep pasting down the column and not overwrite but it depends where you are pasting

 

[Fluff]

How about

   If Not ws Is Nothing Then
   
      nextrow = SummarySheet.Range("Q" & Rows.Count).End(xlUp).Offset(1).Row
      ' Copy over the values from the source to the destination next row.
      SummarySheet.Range("P" & nextrow).Value = ws.Range("A1").Value
      SummarySheet.Range("Q" & nextrow).Resize(3).Value = Application.Transpose(ws.Range("B2:D2").Value)
      SummarySheet.Range("R" & nextrow).Resize(3).Value = Application.Transpose(ws.Range("B3:D3").Value)
      SummarySheet.Range("S" & nextrow).Resize(3).Value = Application.Transpose(ws.Range("B6:D6").Value)
      
      counter = counter + 1
   End If