使用 VBA 重新排列数据

Question

如果能找到解决问题的正确方法，我将不胜感激。

我正在尝试遍历所有工作表（“表 1”和“输出”除外。

上面引用的所有工作表都包含从单元格 A2 到最后一列和最后一行的数据。我需要在“输出”工作表的单元格 C2 中复制所有循环范围（一个在另一个之下）。

此外，我在所有工作表中的 A1 中都有一个唯一编号（除了需要在我的“输出”工作表中复制到 B2 中的“工作表 1”和“输出”。诀窍是（我正在努力） A1 中的值需要在我的“输出”工作表中通过数字 A2 复制到 B2 中：所有循环工作表中的最后一行。

以下是我目前的代码：

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