Makro zum Kopieren mehrerer Zellbereiche und Einfügen in einer Zeile auf einem anderen Blatt

Question

Ich habe ein Makro aufgezeichnet, was ich versuche, einen Code zu erstellen, der den folgenden Bereich im Code auf jedem Arbeitsblatt kopieren und in Zeilen einfügen wird Untereinander auf dem Blatt "Master".

Ich habe den folgenden 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 

Zum Beispiel: Auf Blatt 1, 2, 3 Kopieren der folgende Bereich auf jedem Blatt und füge als Werte in Master-Blatt in der Zelle B1 beginnt. So Blatt 1 Datenbereich in B1 sein sollte, soll Blatt 2 Datenbereich in b2 sein und Blatt 3 Datenbereich in b3 sein sollte und etc ....

Jungs meiner Arbeitsmappe hat mehr als 50 Blatt

Answer 1

Etwas wie sollte für Sie arbeiten:

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 

Answer 2

hier ist eine Alternative "Formel" -Ansatz

andere als in einem alternativen Ansatz setzen, sondern reduziert auch die Anzahl der Iterationen von (nsheets-1) * ncells (per Tigeravatar-Lösung) zu (nsheets-1) + ncells, sollte es jemals ein releva sein nt Ausgabe

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 

es lässt die Blätter in der Spalte „A“ nennen: sie

entfernt werden kann