Need Help Modifying Current Macro

[cjvenables]

Hello,

The current macro copies everything from every sheet in a workbook and pastes it to a single sheet. Since there are usually 150K cells on each sheets, and I have 12 sheets (1 for each month), I need to edit this macro to only copy the row if there is something in Column Q. While Columns A-P usually have 150-200K cells, Column Q only has 10-15K cells. Since I run another macro before this, everything in Column Q is sorted from the top, so it has all of the data I want. It would be nice if I could get the effect of selecting Q2, CTRL+SHIFT, arrow key down to the last cell, and then left arrow key over to copy all information. It runs really fast, so hopefully this will not slow it down too much.

Help is greatly appreciated!

Sub Merge()
Dim ws As Worksheet
ActiveSheet.UsedRange.Offset(0).Clear
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.UsedRange.Copy
Range("A1020000").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Next
End Sub

 

[VoG]

Try

Sub Merge()
Dim ws As Worksheet, LR As Long
ActiveSheet.UsedRange.Offset(0).Clear
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> ActiveSheet.Name Then
        With ws
            LR = .Range("Q" & Rows.Count).End(xlUp).Row
            .Range("A2:Q" & LR).Copy
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlFormats
        End With
    End If
Next ws
End Sub

 

[njimack]

LIke this?

Sub Merge()
Dim ws As Worksheet
Dim LR As Long
ActiveSheet.UsedRange.Offset(0).Clear
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then
With ws
    LR = .Range("Q" & Rows.Count).End(xlUp).Row
    Range(.Cells(2, 1), .Cells(LR, 17)).Copy
End With
With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .PasteSpecial xlValues
    .PasteSpecial xlFormats
End With
End If
Next
Application.ScreenUpdating = True
End Sub

 

[cjvenables]

@njimack
@VoG

Both worked perfectly. Thanks!