macro to copy column B & C on all sheets in workbook to one master sheet side by side

[ryano]

Hi Guys,

I have been searching for ages but cant figure this one out.

I have a workbook with a ton of sheets. (actually about 80 workbooks, all needing one master summary sheet each)

I need to copy column B and C from every sheet, over to one master sheet, which shows B and C from all sheets side by side

Basically all macros i have tried will either copy all column from all sheets, or actually stack the data all together into 2 columns on the master sheet. Just to clarify if i have 50 sheets in a workbook, i need a master with 100 columns (column B and C from all worksheets)

Any help will be majorly appreciated. Thanks

 

[alansidman]

Try this:

Sub AMS()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim LR As Long
    Dim CopyRng As Range
    Dim lColumn As Long


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    ' Delete the summary sheet if it exists.
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("MergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True


    ' Add a new summary worksheet.
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "MergeSheet"


    ' Loop through all worksheets and copy the data to the
    ' summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then


            ' Find the last column with data on the summary worksheet.
            'Last = LastColumn(DestSh)
            


            lColumn = DestSh.Cells(1, Columns.Count).End(xlToLeft).Column
            LR = sh.Range("B" & Rows.Count).End(xlUp).Row


            ' Specify the range to place the data.
            
            Set CopyRng = sh.Range("B1:C" & LR)
            
            ' This statement copies values and formats from each
            ' worksheet.
            CopyRng.Copy
            With DestSh.Cells(1, lColumn + 1)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With


        End If
    Next


ExitTheSub:


    Application.Goto DestSh.Cells(1)


    ' AutoFit the column width in the summary sheet.
    DestSh.Columns.AutoFit


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[ryano]

Try this:

Sub AMS()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim LR As Long
    Dim CopyRng As Range
    Dim lColumn As Long


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    ' Delete the summary sheet if it exists.
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("MergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True


    ' Add a new summary worksheet.
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "MergeSheet"


    ' Loop through all worksheets and copy the data to the
    ' summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then


            ' Find the last column with data on the summary worksheet.
            'Last = LastColumn(DestSh)
            


            lColumn = DestSh.Cells(1, Columns.Count).End(xlToLeft).Column
            LR = sh.Range("B" & Rows.Count).End(xlUp).Row


            ' Specify the range to place the data.
            
            Set CopyRng = sh.Range("B1:C" & LR)
            
            ' This statement copies values and formats from each
            ' worksheet.
            CopyRng.Copy
            With DestSh.Cells(1, lColumn + 1)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With


        End If
    Next


ExitTheSub:


    Application.Goto DestSh.Cells(1)


    ' AutoFit the column width in the summary sheet.
    DestSh.Columns.AutoFit


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Thank you so much!! this worked perfectly - you have no idea how much grief you have saved me

 

[alansidman]

You are most welcome

 

[djnoxi]

Hello,

I tried to use the code provided by you and I have one problem that I can't figure it out.

When I change the row number from 1 to 3 in order to copy the data on row 3, the macro don't place the data from sheet 2 next to the last column but over the data copied from sheet 1.
Can you help me understand what do I do wrong.
This is the code that I used:

Sub capabilitati()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim LR As Long
Dim CopyRng As Range
Dim lColumn As Long


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Cap").Delete
On Error GoTo 0
Application.DisplayAlerts = True


' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Cap"


' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then


' Find the last column with data on the summary worksheet.
'Last = LastColumn(DestSh)



lColumn = DestSh.Cells(1, Columns.Count).End(xlToLeft).Column
LR = sh.Range("D" & Rows.Count).End(xlUp).Row


' Specify the range to place the data.

Set CopyRng = sh.Range("D8:E" & LR)

' This statement copies values and formats from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(2, lColumn + 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With


End If
Next

End Sub



I removed the end of the program where it makes autofit because I don't need it.

Thank you in advance!

 

[alansidman]

I believe if I understand correctly, you will need to move the data down on the destination sheet. This will require that you determine at the start of the loop what the last row employed is. I have modified your code, but it is untested as I don't have your data worksheets. Please note the use of code tags, please use them in the future as it makes reading the code easier.

Option Explicit


Sub capabilitati()Dim sh As Worksheet
 Dim DestSh As Worksheet
Dim LR As Long, LDest As Long [COLOR=#ff0000]'Note here[/COLOR]
Dim CopyRng As Range
Dim lColumn As Long




With Application
.ScreenUpdating = False
.EnableEvents = False
End With




' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Cap").Delete
On Error GoTo 0
Application.DisplayAlerts = True




' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Cap"




' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then




' Find the last column with data on the summary worksheet.
'Last = LastColumn(DestSh)






lColumn = DestSh.Cells(1, Columns.Count).End(xlToLeft).Column
LR = sh.Range("D" & Rows.Count).End(xlUp).Row
LDest = DestSh.Cells(Destsht.Rows.Count, lColumn).End(xlUp).Row[COLOR=#ff0000] 'Note here[/COLOR]


'sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
' Specify the range to place the data.


Set CopyRng = sh.Range("D8:E" & LR)


' This statement copies values and formats from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(LDest + 1, lColumn + 1)[COLOR=#ff0000] 'Note here[/COLOR]
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With




End If

 

[djnoxi]

Heloo,

Thank you for your replay!

What I meant in my post was that the code paste the information over the last one instead of pasting in the next column.

"
' This statement copies values and formats from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(1, lColumn + 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
"
This should copy the range given and paste in the destination worksheet in the next column, but if I change the no. "1" with "3" from the formula, indicating row 3, it overwrite the data already existing in the destination sheet.

For example I have 3 sheets with column A and B with data and I want to make a sheet that contains the column A and B from all 3 sheets having 6 columns, each A and B from sheet 1, 2 and 3 one next to the other: A1B1A2B2A3B3, like that but not on the first row but in the 3rd or 5th or 7th.

Thank you!

 

[alansidman]

Are there only three sheets that need to be copied? Will there ever be more? If only three, then I think that you really need a whole different module with Select Case statements for each sheet. Suggest you post a new thread with specifically what you are looking for. Explain clearly what you have and what you want and I am sure that someone (it may even be me if I have the time) will provide you with a workable solution. Your issue is clearly very different from the OPs.

 

[Kreso]

Try this:

Sub AMS()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim LR As Long
    Dim CopyRng As Range
    Dim lColumn As Long


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    ' Delete the summary sheet if it exists.
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("MergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True


    ' Add a new summary worksheet.
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "MergeSheet"


    ' Loop through all worksheets and copy the data to the
    ' summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then


            ' Find the last column with data on the summary worksheet.
            'Last = LastColumn(DestSh)
            


            lColumn = DestSh.Cells(1, Columns.Count).End(xlToLeft).Column
            LR = sh.Range("B" & Rows.Count).End(xlUp).Row


            ' Specify the range to place the data.
            
            Set CopyRng = sh.Range("B1:C" & LR)
            
            ' This statement copies values and formats from each
            ' worksheet.
            CopyRng.Copy
            With DestSh.Cells(1, lColumn + 1)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With


        End If
    Next


ExitTheSub:


    Application.Goto DestSh.Cells(1)


    ' AutoFit the column width in the summary sheet.
    DestSh.Columns.AutoFit


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Hi Alan,
Can you please help me with this macro in case I would like to copy column A and F only? I'm working on one project and I have more than 150 sheets with data arranged in same columns and I would like to copy 2 columns from this 150 sheets in new sheet and that all data are copied side by side like A,F,A,F.....

 

[mole999]

Hi Alan,
Can you please help me with this macro in case I would like to copy column A and F only? I'm working on one project and I have more than 150 sheets with data arranged in same columns and I would like to copy 2 columns from this 150 sheets in new sheet and that all data are copied side by side like A,F,A,F.....

Please read the post, this is an old thread, You should start a new thread and consider pointing to this thread as a question to support your code. Directly approaching contributors you have had no previous dealings with won't necessarily get you a response.