Реорганизация данных с помощью VBA

Question

Я очень благодарен за помощь в поиске правильного подхода к решению моей проблемы.

Я пытаюсь перебрать все рабочие листы (для «Листа 1» и «выхода» за исключение.

Всех вышеуказанных ссылочных листы содержат данные из ячейки A2 в последнюю колонку и последнюю строку. Мне нужно скопировать все (один ниже другого) в ячейке C2 на моем листе «Выход».

Также у меня есть уникальный номер в A1 во всех листах (кроме «Лист 1» и «Выход», который необходимо скопировать в B2 на моем листе «Выход». Трюк (с которым я борюсь), значение A1 необходимо скопировать вниз в B2 на моем листе «Выход» по номеру A2: последняя строка во всех моих зацикленных листах.

Ниже мой код до сих пор:

Sub EveryDayImShufflingData() 

    Dim ws As Worksheet 
    Dim PasteSheet As Worksheet 
    Dim Rng As Range 
    Dim lRow As Long 
    Dim lCol As Long 
    Dim maxRow As Integer 
    Dim x As String 

    Set PasteSheet = Worksheets("Output") 

    Application.ScreenUpdating = False 

    'Loop through worksheets except "Sheet 1" and "Output" 
    For Each ws In ActiveWorkbook.Worksheets 
     If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then 

      'Select the Worksheet 
      ws.Select 

      'With each worksheet 
      With ws 

       'Declare variables lRow and lCol 
       lRow = .Cells(Rows.Count, 1).End(xlUp).Row 
       lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column 

       'Set range exc. VIN 
       Set Rng = .Range(.Cells(2, 1), .Cells(lRow, lCol)) 

       'Paste the range into "Output" worksheet 
       Rng.Copy 
       PasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 

       x = .Cells(1, 1).Value 

       For i = 1 To lRow 
        PasteSheet.Cells(i, 2).End(xlUp).Offset(1, 0) = x 
        maxRow = maxRow + 1 
       Next 

       Application.CutCopyMode = False 
       Application.ScreenUpdating = True 

      End With 
     End If 
    Next ws 
End Sub 

Любая помощь будет любезно оценили

Answer 1

Попробуйте это:

Sub EveryDayImShufflingData()  
    Dim ws As Worksheet, copyRng As Range, lRow As Long, lCol As Long, PasteSheet As Worksheet 

    Set PasteSheet = Worksheets("Output") 

    For Each ws In ActiveWorkbook.Worksheets 
     If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then 

      lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 
      lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column 

      Set copyRng = ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol)) 

      copyTargetCell = PasteSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1 

      copyRng.Copy Destination:=PasteSheet.Range("C" & copyTargetCell) 

      Worksheets("Output").Range("B" & copyTargetCell & ":B" & (copyTargetCell + copyRng.Rows.Count - 1)) = ws.Range("A1") 
     End If 
    Next ws 
End Sub