使用VBA重新排列数据

如果能找到解决我的问题的正确方法，我将非常感激

我试图循环浏览所有工作表（除了“工作表1”和“输出”）

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

此外，我在所有工作表的A1中都有一个唯一的数字（需要复制到“输出”工作表B2中的“工作表1”和“输出”除外）。诀窍是（我正在努力解决这个问题）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

Sub EveryDayImShufflingData（）
将ws设置为工作表
将工作表粘贴为工作表
变暗Rng As范围
暗淡的光线和长的一样
暗淡的lCol尽可能长
Dim maxRow作为整数
将x作为字符串
设置粘贴页=工作表（“输出”）
Application.ScreenUpdating=False
'循环浏览除“工作表1”和“输出”之外的工作表'
对于ActiveWorkbook.Worksheets中的每个ws
如果（ws.Name“Sheet1”）和（ws.Name“Output”）以及（ws.Visible=True），则
'选择工作表
ws.Select
'每个工作表
与ws
'声明变量lRow和lCol
lRow=.Cells（Rows.Count，1）.End（xlUp）.Row
lCol=.Cells（2，.Columns.Count）.End（xlToLeft）.Column
'设置车辆识别号以外的范围
设置Rng=.Range（.Cells（2，1），.Cells（lRow，lCol））
'将范围粘贴到“输出”工作表中
收到
PasteSheet.Cells（Rows.Count，3）.End（xlUp）.Offset（1，0）.粘贴特殊的xlpasteValue
x=.Cells（1，1）.Value
对于i=1至lRow
粘贴页。单元格（i，2）。结束（xlUp）。偏移量（1，0）=x
maxRow=maxRow+1
下一个
Application.CutCopyMode=False
Application.ScreenUpdating=True
以
如果结束
下一个ws
端接头

任何帮助都将不胜感激

请尝试以下方法：

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

Sub EveryDayImShufflingData（）
将ws设置为工作表，将copyRng设置为范围，将lRow设置为长，将lCol设置为长，将PasteSheet设置为工作表
设置粘贴页=工作表（“输出”）
对于ActiveWorkbook.Worksheets中的每个ws
如果（ws.Name“Sheet1”）和（ws.Name“Output”）以及（ws.Visible=True），则
lRow=ws.Cells（ws.Rows.Count，1）.End（xlUp）.Row
lCol=ws.Cells（2，ws.Columns.Count）.End（xlToLeft）.Column
设置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）
工作表（“输出”）.Range（“B”和copyTargetCell&“：B”和（copyTargetCell+copyRng.Rows.Count-1））=ws.Range（“A1”）
如果结束
下一个ws
端接头

谢谢你，Alex P！很有魅力。如果我想给你的代码和“输出”中A2单元格增加一层复杂性，请在“Sheet1”中索引（A2:a和lastrow），在“输出”中匹配（B2，（B2:B和lastrow，0）。我如何做到这一点并填写公式到最后一行对不起，在Sheet1中B2:B和lastrow