Excel VBA-使用數組在工作表中移動，然后復制粘貼第n行

Question

我對VBA有點陌生，最近我才開始在excel中使用它，但遇到了障礙。

我正在創建人行橫道，以便將我的數據上傳到商業智能應用程序。 不幸的是，我沒有與數據庫的連接來運行我的報告，因此我必須使用excel來完成。 我遇到的問題是我們的應用程序中存在一個錯誤，該錯誤在excel文檔的第1000行之后將跳過每1000行。 我們的開發團隊已經意識到了這一點，但是沒有ETA可以解決問題。 作為解決方法，我試圖使用VBA將第1000行（從2000開始）復制到同一張紙的末尾。

目前，我已經為此代碼編寫了可在單個工作表上工作的代碼，但是我有幾頁具有超過1000行，因此我試圖將這些工作表的名稱輸入一個數組，並循環遍歷每個表並進行復制/粘貼。 。

我的1個工作表的工作代碼：

Sub Test()

Dim WB As Workbook
Dim WS As Worksheet
Dim i As Integer
Dim x As Integer
Dim r As Range



Set WB = Workbooks("macrotesting.xlsm")
Set WS = Worksheets("Usage")

Set r = WS.UsedRange
k = r.Rows.Count
x = 2000
i = 2

Do While x < k

WS.Range(("A" & x) & (":L" & x)).Copy
WS.Rows.End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

i = i + 1
x = 1000 * i

Loop

End Sub

我可以在這里找到一些幫助，但是失敗了。 數組代碼：

Sub Test()

Dim wsArray As Variant
Dim wsArrayCrnt As Variant
Dim i As Integer
Dim x As Integer
Dim r As Range

wsArray = Array("Usage", "Use")

For Each wsArrayCrnt In wsArray
With Worksheets(wsArrayCrnt)

    r = .UsedRange
    k = r.Rows.Count
    x = 2000
    i = 2

    Do While x < k

    .Range(("A" & x) & (":L" & x)).Copy
    .End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

    i = i + 1
    x = 1000 * i

    Loop
End With
Next wsArrayCrnt

End Sub

它似乎在失敗

 k = r.Rows.Count

雖然我不確定此后是否會完成。

我還嘗試過對工作簿進行標注，並將其添加到with語句以及之后的所有變量中。

Answer 1

除了手動輸入所需的工作表外，您還不能僅瀏覽工作簿中的所有工作表嗎？

Sub test()
Dim i As Integer
Dim x As Integer
Dim r As Range

For Each wsheet In ActiveWorkbook.worksheets

    Set r = wsheet.UsedRange
    k = r.Rows.Count
    x = 2000
    i = 2

    Do While x < k
        wsheet.Range(("A" & x) & (":L" & x)).Copy
        wsheet.Rows.End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

        i = i + 1
        x = 1000 * i
    Loop

Next wsheet

End Sub

這將在您正在運行宏的當前工作簿中的每個工作表中循環，並將每第1000行復制到工作表的末尾。

（任何少於2000行的工作表都將跳過do while循環並被忽略）

Answer 2

您必須輸入

Set r = .UsedRange

由於UsedRange是一個對象（即Range對象）

您可能還希望使用更緊湊的代碼，如下所示：

Sub Test()

Dim wsArrayCrnt As Variant
Dim x As Long

For Each wsArrayCrnt In Array("Usage", "Use")
    With Worksheets(wsArrayCrnt)
        x = 2000
        Do While x < .UsedRange.Rows.Count
           .Range(("A" & x) & (":L" & x)).Copy
           .End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
           x = x + 1000
       Loop
    End With
Next wsArrayCrnt

End Sub