Copy the same two columns from 5 sheets into one sheet?

**jvk76** · 10-29-2012, 01:01 AM

Can anyone help with a macro to do the following?
1. Copy data from Column A3 down to the last entry point (last entry will increase further down every week).
2. Copy data from Column AM3 down to last entry point (last entry will increase further down every week).
3. Copy column data 1 & 2 from more than one sheet, sheets "01" , "02" , "03" , "04" , "05" .
THEN
4. Put into a new sheet on same worksheet called "SUMMARY" A3 combined data in column A, and all AM3 combined data in column B.

Thank you,

Working on this as you read this but have yet to figure it out.

**JBeaucaire** · 10-29-2012, 02:22 AM

Give this a try:

Sub ConsolidateData()
Dim ws As Worksheet, wsSUM As Worksheet, LR As Long

Set wsSUM = ThisWorkbook.Sheets("SUMMARY")
wsSUM.Range("A:B").Clear

For Each ws In Sheets(Array("01", "02", "03", "04", "05"))
    With ws
        .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Copy wsSUM.Range("A" & Rows.Count).End(xlUp).Offset(1)
        .Range("AM3", .Range("AM" & .Rows.Count).End(xlUp)).Copy wsSUM.Range("B" & Rows.Count).End(xlUp).Offset(1)
    End With
Next ws

End Sub

**jvk76** · 10-29-2012, 01:19 PM

Thank you, that worked good but only grabbed column A3 down from Sheet 01. It grabbed all columns AM3 perfectly, just it was missing the corresponding A column once we got to sheet 02. So I had a lot of "0"s at on the final Column A towards the bottom.

Can you set it to grab the data but only paste values for column A3, maybe that was the issue? As the original Column A3 is a blend of data using other functions.

**:) Sixthsense :)** · 10-29-2012, 03:19 AM

The below code is lengthy when comparing to JBeaucaire's code. But me too tried to get solution for your query and spent some time in writing the below code. So posting the code even though you got the shorter code.

Option Explicit

Sub ConsolidateData()
Dim mSh As Worksheet, i As Byte, LRw As Long
Dim arrSh() As Worksheet, shFound As Boolean
Dim UsrSel As Byte, CursrLoc As Range

ReDim arrSh(1 To 5)

Set arrSh(1) = Sheets("01")
Set arrSh(2) = Sheets("02")
Set arrSh(3) = Sheets("03")
Set arrSh(4) = Sheets("04")
Set arrSh(5) = Sheets("05")

For i = 1 To Sheets.Count
    If Sheets(i).Name = "Summary" Then
        shFound = True
        Exit For
    End If
Next i

If shFound Then
    UsrSel = MsgBox("Summary Sheet Already Exist." _
             & "Do you want to replace it with New Sheet?" _
             , vbQuestion + vbYesNo + vbDefaultButton2, "Sheet Exist")
    
    If UsrSel = 6 Then
        Application.DisplayAlerts = False
        Sheets("Summary").Delete
        Application.DisplayAlerts = True
    Else
        MsgBox "Unable to continue, since sheet already exist"
        Application.ScreenUpdating = True
        Exit Sub
    End If
End If

Application.ScreenUpdating = False

Sheets.Add Before:=Sheets(1)

ActiveSheet.Name = "Summary"
Set mSh = ActiveSheet

For i = 1 To UBound(arrSh())
    arrSh(i).Select
    Set CursrLoc = ActiveCell
    Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row).Select
    Selection.Copy
    CursrLoc.Select
    
    mSh.Select
    LRw = Cells(Rows.Count, "A").End(xlUp).Row
    Cells(LRw + 1, "A").Select
    Selection.PasteSpecial xlPasteAll
    
    arrSh(i).Select
    Set CursrLoc = ActiveCell
    Range("AM3:AM" & Cells(Rows.Count, "AM").End(xlUp).Row).Select
    Selection.Copy
    CursrLoc.Select

    mSh.Select
    LRw = Cells(Rows.Count, "AM").End(xlUp).Row
    Cells(LRw + 1, "AM").Select
    Selection.PasteSpecial xlPasteAll
    Range("A3").Select
    
Next i

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

**JBeaucaire** · 10-29-2012, 04:49 PM

Who are you talking to? If me:

Sub ConsolidateData()
Dim ws As Worksheet, wsSUM As Worksheet, LR As Long

Set wsSUM = ThisWorkbook.Sheets("SUMMARY")
wsSUM.Range("A:B").Clear

For Each ws In Sheets(Array("01", "02", "03", "04", "05"))
    With ws
        .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Copy 
        wsSUM.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        .Range("AM3", .Range("AM" & .Rows.Count).End(xlUp)).Copy 
        wsSUM.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    End With
Next ws

End Sub

**jvk76** · 10-29-2012, 11:53 PM

JBeaucaire, thank you, that did it. Awesome.

Now, I ran into a problem where this new data combined is too long for the database we work with. It needs to be broken up into sheets totaling no more than 3,500 rows. This generated 16,300 rows =) when combined. So Summary1, Summary2, Summar3, etc as needed worksheets is my next step. Thank you, this is a huge relief as is. In the meantime, I check with the website software and see if they can't change limits.

**JBeaucaire** · 10-30-2012, 01:59 AM

'ROWS TO SHEETS
Here's a macro for taking a sheet and splitting into multiple sheets based on X-rows per sheet.

Rows to Sheets

The original question has been resolved, so this thread should really be closed. Please select Thread Tools from the menu above and mark the thread as solved. Thanks.