Excel VBA在工作簿范圍之間復制/粘貼

Question

我曾經經常在VBA中進行編碼，但是已經過了幾年，我為此感到沮喪。 以下代碼似乎有問題（對於從中打開/復制的前9個文件而言，它工作正常（盡管非常緩慢）），然后出現宏錯誤，並導致excel掛起，需要重新啟動。 我在此論壇上從luke_t借用/修改了一篇較早的文章，以達到目的。 據我所知，第9個文件沒有什么區別，因為它們都是基於標准模板的，但是錯誤可能在那里？

    Sub copy_rng()
Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
Dim wbNames() As Variant
Dim destPath As String
Dim fullpath As String
Dim outputrow As Variant, i As Byte

Set wb = ThisWorkbook
Set ws = wb.Sheets("Casing")
Set wsSrc = wb.Sheets("Casing")
wbNames = ws.Range("b5:b" & lrow(2, ws))

destPath = "C:\Users\...\Daily Reports\"
outputrow = 5

Application.ScreenUpdating = False

For i = 1 To UBound(wbNames, 1)

    fullpath = destPath & wbNames(i, 1)
    MsgBox i & " " & fullpath
    'Stop

    Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
    Set wsDest = wbDest.Sheets("Field Report (Internal)")

    With wsDest
        .Range(Cells(27, 17), Cells(27, 19)).Copy
    End With
    wsSrc.Cells(outputrow, 10).PasteSpecial xlPasteValues

    With wsDest
        .Range(Cells(28, 17), Cells(28, 19)).Copy
    End With
    wsSrc.Cells(outputrow, 13).PasteSpecial xlPasteValues

    With wsDest
        .Range(Cells(29, 17), Cells(29, 19)).Copy
    End With
    wsSrc.Cells(outputrow, 16).PasteSpecial xlPasteValues

    Application.CutCopyMode = False

    wbDest.Close False

    outputrow = outputrow + 1

Next i

Application.ScreenUpdating = True
    End Sub

    Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
    End Function

Answer 1

好吧，終於找到了這個。 整理代碼以使其更清晰，但我認為我的問題不是專門針對代碼，而是因為我還沒有為我要提取的某些基於日期的信息創建文件，即我已經將來要創建的文件的日期，並且沒有錯誤檢查這些文件是否存在。 我沒有添加錯誤檢查，而是暫時刪除了將來的日期引用，因為這樣做更快。

Sub copy_rng()
Dim wb As Workbook, wbToOpen As Workbook, ws As Worksheet, wsSource As Worksheet
Dim wbNames() As Variant
Dim filePath As String
Dim outputrow As Variant, i As Byte
Dim srcOneRange As Range, srcTwoRange As Range, srcThreeRange As Range

Set wb = ThisWorkbook
Set ws = wb.Sheets("Casing")
wbNames = ws.Range("b5:b" & lrow(2, ws))

filePath = "C:\Users\...\Daily Reports\" 'set path to your path
outputrow = 5

For i = 1 To UBound(wbNames, 1)
    Application.ScreenUpdating = False

    Set wbToOpen = Workbooks.Open(filePath & wbNames(i, 1))
    Set wsSource = wbToOpen.Sheets("Field Report (Internal)")

    Set srcOneRange = wsSource.Range("q27:s27")
    Set srcTwoRange = wsSource.Range("q28:s28")
    Set srcThreeRange = wsSource.Range("q29:s29")

    ws.Activate

    With ws
        .Range(Cells(outputrow, 10), Cells(outputrow, 12)).Value = srcOneRange.Cells.Value
        .Range(Cells(outputrow, 13), Cells(outputrow, 15)).Value = srcTwoRange.Cells.Value
        .Range(Cells(outputrow, 16), Cells(outputrow, 18)).Value = srcThreeRange.Cells.Value
    End With


    wbToOpen.Close False

    outputrow = outputrow + 1

    Application.ScreenUpdating = True

    DoEvents
    ActiveWindow.SmallScroll down:=1

    Application.WindowState = Application.WindowState

Next i

Application.ScreenUpdating = True

End Sub