макрос для копирования нескольких диапазонов ячеек и вставки в строке на другом листе

Question

Я записал макрос. То, что я пытаюсь получить, - это создать код, который скопирует следующий код в коде на каждом листе и вставляет его в строки под друг друга на листе «Мастер».

У меня есть следующий код:

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 

Например: На листе 1, 2, 3 Скопируйте следующий диапазон на каждом листе и вставить в качестве значения в листе Master Cell, начиная с B1. Таким образом, диапазон листа 1 данные должны быть в B1, листовое диапазон 2 данные должны быть в b2, и лист 3 диапазона данных должны быть в b3 и т.д. ....

Ребята моя книга имеет более 50 листов

Answer 1

Something как должны работать для вас:

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

здесь альтернатива «формула» подход

, кроме сдачи в альтернативном подходе, он также уменьшает количество итераций из (nsheets-1) * ncells (в соответствии с решение tigeravatar) к (nsheets-1) + ncells, если это когда-либо будет актуальным нт вопрос

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 

оставляет листы имя в колонке «А»: они могут быть удалены