使用VBA重新排列数据

Question

我真的很感谢一些帮助，找到解决我的问题的正确方法。

我通过所有工作表试图循环（除了“表1”和“输出”。

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

另外我在所有工作表中都有一个唯一编号（需要复制的“工作表1”和“输出”除外在我的“输出”工作表中输入B2，技巧是（我正在努力工作）A1中的值需要在我的“输出”工作表中复制下来，数字为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