Скопируйте одни и те же несмежные данные по одному и тому же адресу ячейки из нескольких таблиц и вставьте в одну главную таблицу

Question

Как скопировать несмежные ячейки (A2, B4, D5, E1, F3) с разных листов (лист1 на лист 4) и вставить в один мастер листы ("sheet5") строка за строкой?

Вывод должен выглядеть в виде таблицы:

cell A2 cell B4 cell D5 cell E1 cell F3 sheet 1
cell A2 cell B4 cell D5 cell E1 cell F3 sheet 2
cell A2 cell B4 cell D5 cell E1 cell F3 sheet 3
cell A2 cell B4 cell D5 cell E1 cell F3 sheet 4

Dim cel As Range, pasteRange As Range

Dim sht As Worksheet

Set pasteRange = ActiveWorkbook.Sheets("Sheet5").Range("A2")

   For Each sht In Sheets
      If sht.name <> "Sheet5" Then

        For Each cel In sht.Range("A2, B4, D5, E1, F3")

            pasteRange.Value = cel.Value

            Set pasteRange = pasteRange.Offset(0, 1)

        Next

    End If

Next

Answer 1

Посмотрите, поможет ли это:

Dim cel As Range, pasteRange As Range
Dim X As Long, Z As Long
Dim wb As Workbook: Set wb = ActiveWorkbook

Set pasteRange = wb.Sheets("Sheet5").Range("A2")

For X = 1 To 4
    With wb.Sheets("Sheet" & X)
        For Each cel In .Range("A2, B4, D5, E1, F3")
            pasteRange.Offset(X - 1, Y).Value = cel.Value
            Y = Y + 1
        Next cel
    End With
    Y = 0
Next X