Copy Non Contiguous Ranges From Multiple Worksheets To New Worksheet

ZTURN · Feb 5th 2008

Hello,

Based on searching previous posts, I am now able to copy one row of data from multiple worksheets. However, I now need to copy multiple rows of data from the worksheets into a Summary worksheet.

For instance, after pasting one row of data containing values from Z3,P43,C9:D9,AJ9, I need to paste a new row of data containing values from Z3,P43,C10:D10,AJ10. The process should continue for 33 rows of data before moving to the next worksheet.

(From sheet 1)
Z3,P43,C9:D9,AJ9
Z3,P43,C10:D10,AJ10
.
.
Z3,P43,C33:D33,AJ33
(Move to sheet 2)

I really appreciate your help. Thanks.

Code

Sub Macro1()
    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    Sheets("Summary").Activate
    
    Cells.Select
    Selection.NumberFormat = "General"
     
    For Each ws In Worksheets
        If ws.Name <> "Summary" Then
 
            ws.Range("Z3").Copy
            Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
            ws.Range("P43").Copy
            Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(0, 1).PasteSpecial (xlPasteValues)
            ws.Range("C9:D9").Copy
            Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(0, 2).PasteSpecial (xlPasteValues)
            ws.Range("AJ9").Copy
            Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(0, 4).PasteSpecial (xlPasteValues)
        End If
    Next ws
    
    Columns("B:B").Select
    Selection.NumberFormat = "0.00%"
End Sub

Display More

[hr]*[/hr] Auto Merged Post;[dl]*[/dl]Hello,

I haven't received a response. Can this be done? I have attached a sample worksheet if it helps.

Thanks again.

lecxe · Feb 7th 2008

Re: Copy Non Contiguous Ranges From Multiple Worksheets To New Worksheet

Hi ZTURN

If I understood correctly you want to copy 25 rows of each worksheet.

Try:

Code

Sub Macro1()
    Dim ws As Worksheet, lRow As Long, lCopy As Long
     
    Application.ScreenUpdating = False
    With Sheets("Summary")
     
        .Cells.NumberFormat = "General"
        
        lCopy = 25 ' number of rows to copy
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
        For Each ws In Worksheets
            If ws.Name <> "Summary" Then


                .Cells(lRow, "A").Resize(lCopy, 1).Value = ws.Range("Z3").Value
                .Cells(lRow, "B").Resize(lCopy, 1).Value = ws.Range("P43").Value
                .Cells(lRow, "C").Resize(lCopy, 2).Value = ws.Range("C9:D9").Resize(lCopy, 2).Value
                .Cells(lRow, "E").Resize(lCopy, 1).Value = ws.Range("AJ9").Resize(lCopy, 1).Value
                lRow = lRow + lCopy
            End If
        Next ws
         
        .Columns("B:B").NumberFormat = "0.00%"
    End With
    Application.ScreenUpdating = True
End Sub

Display More

ZTURN · Feb 7th 2008

Re: Copy Non Contiguous Ranges From Multiple Worksheets To New Worksheet

Thanks. I will give it a try.

Copy Non Contiguous Ranges From Multiple Worksheets To New Worksheet

Participate now!

Share