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

Excel VBA在工作簿范围之间复制/粘贴

1 个答案: