macro to copy multiple cell ranges and paste in a row on another sheet

Question

I recorded a macro, What I'm trying to obtain is creating a code that will copy the following range in the code on each worksheet and paste it in rows underneath each other on sheet "Master".

I have the following code:

Sub Macro1()
'
' Macro1 Macro
'

'
 Dim rng As Range
Sheets("AL-Jackson Hospital-Fvar").Select

Set rng = Range( _
"K50:M50,K58:M58,K59:M59,K55:M55,K12:M12,K14:M14,K24:L24,K28:L28,K29:L29,K35:L35,K62:L62,K32:L32,K30:L30,K31:L31,K63:L63,K33:L33,K34:L34,K37:L37,K40:L40,K41:L41,K42:L42,K46:L46" _
    )
rng.Select
Selection.Copy
Sheets("Master").Select
Range("B4").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst

End Sub

For example: On sheet 1, 2 ,3 Copy the following range on each sheet and paste as values in sheet Master starting in Cell B1. So sheet 1 data range should be in B1, sheet 2 data range should be in b2, and sheet 3 data range should be in b3 and etc....

Guys my workbook has over 50 sheets

What's the point of setting the range, if you're just going to use `select` immediately after XD Also, not sure if you can set range in that fashion... And you're not looping sheets at all. — findwindow, Apr 21 '16 at 19:17
@findwindow Setting range was something I found on here. I was testing different framework as far as copying multiple ranges. — user3666237, Apr 21 '16 at 19:20
The super basic way is to do: `Sheets("Sheet1").Range("A1").Copy Sheets("Sheet2").Range("A1").Paste`. Also, you'll want to get rid of `.Select`, so I ***highly*** recommend reading through [this SO thread](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros). If you just want values, you can set two ranges equal instead of `.Copy`: it goes `[destination range] = [what your original range is]`, so with my previous example, `Sheets("Sheet2").Range("A1").Value = Sheets("Sheet1").Range("A1").Value` — BruceWayne, Apr 21 '16 at 19:21
Thanks @BruceWayne I'm going to check it out. I'll keep you guys posted — user3666237, Apr 21 '16 at 19:27
You _can_ set a range that way! But yea do what Batman said. — findwindow, Apr 21 '16 at 19:28
@BruceWayne thanks but I thought their was a easier shorter way of doing this without having to go one by one. Also keep in mind I gave a basic example my workbook contains 50 sheets that code can be exhaustive — user3666237, Apr 21 '16 at 19:28
If you're just doing some copy/pasting, you can just loop through your sheets. I suggest using range variables (like you started to). The code doesn't necessarily have to be way long if you're using it over 50 sheets. — BruceWayne, Apr 21 '16 at 19:29
@findwindow Yeah that can work but my workbook has over 50 sheets and 22 ranges that I want to copy from each — user3666237, Apr 21 '16 at 19:30

score 4 · Accepted Answer · answered Apr 21 '16 at 19:42

Something like should work for you:

Sub tgr()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsDest As Worksheet
    Dim rCell As Range
    Dim aData() As Variant
    Dim sCells As String
    Dim i As Long, j As Long

    Set wb = ActiveWorkbook
    Set wsDest = wb.Sheets("Master")
    sCells = "K50:M50,K58:M58,K59:M59,K55:M55,K12:M12,K14:M14,K24:L24,K28:L28,K29:L29,K35:L35,K62:L62,K32:L32,K30:L30,K31:L31,K63:L63,K33:L33,K34:L34,K37:L37,K40:L40,K41:L41,K42:L42,K46:L46"

    ReDim aData(1 To wb.Sheets.Count - 1, 1 To wsDest.Range(sCells).Cells.Count)

    i = 0
    For Each ws In wb.Sheets
        If ws.Name <> wsDest.Name Then
            i = i + 1
            j = 0
            For Each rCell In ws.Range(sCells).Cells
                j = j + 1
                aData(i, j) = rCell.Value
            Next rCell
        End If
    Next ws

    wsDest.Range("B1").Resize(UBound(aData, 1), UBound(aData, 2)).Value = aData

End Sub

You are an array master. Please teach me to be like you. Edit: not just array. Your architecture is brilliant ^_^ — findwindow, Apr 21 '16 at 19:43
@tigeravatar I agree with findwindow I bow down please teach us. Thanks by the way — user3666237, Apr 21 '16 at 19:48

score 1 · Answer 2 · answered Apr 22 '16 at 09:18

here's an alternative "formula" approach

other than putting in an alternative approach, it also reduces the number of iterations from (nsheets-1)*ncells (as per tigeravatar's solution) to (nsheets-1) + ncells, should it ever be a relevant issue

Option Explicit

Sub main()

    Dim ws As Worksheet
    Dim cell As Range, refCell As Range

    With ActiveWorkbook.Sheets("Master")
        For Each ws In wb.Sheets
             .Cells(.Rows.Count, 1).End(xlUp).Offset(1) = IIf(ws.Name <> .Name, ws.Name, "")
        Next ws
        Set refCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)

        For Each cell In Range("K50:M50,K58:M58,K59:M59,K55:M55,K12:M12,K14:M14,K24:L24,K28:L28,K29:L29,K35:L35,K62:L62,K32:L32,K30:L30,K31:L31,K63:L63,K33:L33,K34:L34,K37:L37,K40:L40,K41:L41,K42:L42,K46:L46")
            .Cells(refCell.Row, .Columns.Count).End(xlToLeft).Offset(, 1).Value = cell.Address ' set the reference for INDIRECT() function
        Next cell
        With .Range("B2", .Cells(refCell.Row, .Columns.Count).End(xlToLeft).Offset(-1))
            .FormulaR1C1 = "=INDIRECT(ADDRESS(ROW(INDIRECT(R" & refCell.Row & "C)),COLUMN(INDIRECT(R" & refCell.Row & "C)),,,RC1))"
            .Value = .Value
            .Offset(.Rows.Count).Resize(1).ClearContents
        End With
    End With

End Sub

it leaves the sheets name in column "A": they can be removed

macro to copy multiple cell ranges and paste in a row on another sheet

2 Answers2