Question

我真的很感激帮助找到解决问题的正确方法。

我正在尝试遍历所有工作表（＆＃34;工作表1和＃34;以及＆＃34;输出＆＃34;。

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

此外，我在所有工作表中的A1中都有一个唯一的编号（＃34;第1页和第34页除外;＆＃34;输出＆＃34;需要在我的＆＃34;输出＆＃中复制到B2中34;工作表。诀窍是（我正在努力）A1中的值需要在我的＆＃34;输出＆＃34;工作表中被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

使用VBA重新排列数据

1 个答案: