Question

我目前正在使用一个工作簿，并且想要实施准备工作，请从单独的工作表（最多3个工作表）中复制/粘贴我工作簿中的所有相关范围。

我有下面的代码在工作表中循环，不幸的是，我无法编写粘贴命令来连续粘贴同一行中的这些范围。我想要移调：=正确。 I.E Sheet1的Rgn从B2开始，在右边的最后一个填充的单元格从Sheet2开始Rgn之后，最后一个填充的单元格从Sheet3开始Rgn之后（假设Sheet3存在Rgn）。

当前，我的代码覆盖了上一张表格中复制的内容。

我在这里找到了潜在的参考（VBA Copy Paste Values From Separate Ranges And Paste On Same Sheet, Same Row Offset Columns (Repeat For Multiple Sheets)），但是我不确定如何使用地址，也不确定如何在解决方案中设置偏移量。

' Insert temporary tab
Set sh = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
sh.Name = "Prep"


'Loop
For Each sh In wb.Worksheets
    Select Case sh.Index
        Case 1
           Sheets(1).Range("D16:D18").Copy

        Case 2
           lastrow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
           lastcol = Sheets(2).Cells(9, Columns.Count).End(xlToLeft).Column
           Set Rng = Sheets(2).Range("M9", Sheets(2).Cells(lastrow, lastcol))
           Rng.Copy

        Case 3
             'Check if Range (first col for answers) is not empty   
             If Worksheetunction.CountA(Range("L9:L24")) = 0 Then
                   Exit For
             Else
                   lastrow = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
                   lastcol = Sheets(3).Cells(9, Columns.Count).End(xlToLeft).Column
                   Set Rng = Sheets(3).Range("L9", Sheets(3).Cells(lastrow, lastcol))
                   Rng.Copy


              End If

     End Select

     wb.Sheets("Prep").UsedRange.Offset(1,1).PasteSpecial Paste:=xlPasteAll, Transpose:=True

 Next
 Set sh = Nothing
 Set Rng = Nothing

Answer 1

您可以试试吗？ UsedRange可能是不可预测的。如果您在Rng的第一个单元格中没有任何内容，也可能会遇到问题，在这种情况下，此代码需要调整。

我也希望使用表名而不是索引。

Sub x()

Dim sh As Worksheet, wb As Workbook, Rng As Range

Set sh = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
sh.Name = "Prep"

'Loop
For Each sh In wb.Worksheets
    Select Case sh.Index
        Case 1
            Set Rng = sh.Range("D16:D18")
        Case 2
            lastrow = sh.Range("A" & Rows.Count).End(xlUp).Row
            lastcol = sh.Cells(9, Columns.Count).End(xlToLeft).Column
            Set Rng = sh.Range("M9", sh.Cells(lastrow, lastcol))
        Case 3
            'Check if Range (first col for answers) is not empty
            If WorksheetFunction.CountA(sh.Range("L9:L24")) = 0 Then
                Exit For
            Else
                lastrow = sh.Range("A" & Rows.Count).End(xlUp).Row
                lastcol = sh.Cells(9, Columns.Count).End(xlToLeft).Column
                Set Rng = sh.Range("L9", sh.Cells(lastrow, lastcol))
            End If
    End Select
    Rng.Copy
    wb.Sheets("Prep").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next

Set sh = Nothing
Set Rng = Nothing

End Sub

从多张纸复制变化范围并从同一行粘贴

1 个答案: