vba - 您能找到导致我的 Excel VB 脚本速度变慢的原因吗？

Question

首先介绍一点背景知识:我需要一个脚本来获取我选择的目录中的 n 个 CSV 文件，并将它们的各个数据复制并粘贴到“主”Excel 工作簿文件中，其中 >n 个选项卡。我还需要脚本自动将选项卡命名为有用的名称。

我结合了宏录制、我在此处找到的片段以及老式的谷歌搜索，将《弗兰肯斯坦》编写成了一个脚本。它运行时没有太多错误；然而，在该过程接近尾声时(如果有 10 多个 CSV 文件)，速度会显着减慢。

我尝试了几个不同的版本来确保剪贴板被清除，当前正在复制的文件被关闭，抑制主文件的打开和关闭动画等。到目前为止唯一成功的事情是(我认为有效的)清除剪贴板。

我承认这是我第一次接触 Visual Basic，而且我不是专业程序员，因此代码可能无法正确处理内存。

我的问题是:您能发现一个或多个部分/操作正在减慢代码的速度吗？或者至少提供一个可行的解释来解释为什么会发生这种情况？总的来说，我的笔记本电脑并不逊色。这是一台配备 i5 处理器和 8GB RAM 的 HP EliteBook，所以我无法想象这是一个资源问题。

我已经清理了代码和对个人目录的任何引用，并将其发布在下面。

预先感谢您的帮助。

Sub MultiCSV_to_Tabs()
Dim vaFiles As Variant
Dim i As Long
Dim wbkToCopy As Workbook
Dim wbkToPaste As Workbook

vaFiles = Application.GetOpenFilename("CSV Files (*.csv), *.csv", _
          Title:="Select files", MultiSelect:=True)

'User_Created_File = "PLACE YOUR DIRECTORY AND FILE NAME IN BETWEEN THESE QUOTATION MARKS"

If IsArray(vaFiles) Then
    For i = LBound(vaFiles) To UBound(vaFiles)

        'Open the first CSV file in the list of selections
        Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))

        'Split the vaFiles variable on backslashes to dissect the PathName and FileName
        SplitFileName = Split(vaFiles(i), "\")

        'Go find the last entry in the SplitFileName variable. This should be the exported file name we selected.
        ExportedCSVFileName = SplitFileName(UBound(SplitFileName))

        'Select all cells and copy that selection
        wbkToCopy.Application.DisplayAlerts = False
        Cells.Select
        Selection.Copy

        'Close the current workbook without saving changes
        wbkToCopy.Close savechanges:=False

        'Open the summary workbook
        Set wbkToPaste = Workbooks.Open(User_Created_File)

        'Add a new tab to the end of the last tab
        Sheets.Add After:=Sheets(Sheets.Count)

        'Define new sheetname using the parsed filename from the workbook
        shtname = Mid(ExportedCSVFileName, 17, 25)
        ActiveSheet.Name = shtname

        'Paste the selection we copied earlier
        wbkToPaste.Application.DisplayAlerts = False
        ActiveSheet.Paste

        wbkToPaste.Application.CutCopyMode = False

        'Close the summary workbook and save the changes. Go to the next file in the array.
        wbkToPaste.Close savechanges:=True

    Next i

End If

Set wbkToCleanUp = Workbooks.Open(User_Created_File)
Sheets("Sheet1").Delete
wbkToCleanUp.Close savechanges:=True
MsgBox ("Copy/Paste complete")

End Sub

Answer 1

Cells.Select 占用大量内存。找到工作表的实际范围并复制它。

例如

Sub Sample()
    Dim ws As Worksheet
    Dim Lrow As Long, LCol As Long
    Dim rng As Range

    Set ws = Sheet1

    With ws
        '~~> Find Last row which has data
        Lrow = .Cells.Find(What:="*", _
                After:=wks.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

        '~~> Find Last column which has data                    
        LCol = .Cells.Find(What:="*", _
                After:=wks.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column

        Set rng = .Range("A1:" & Split(Cells(, LCol).address, "$")(1) & Lrow)

        rng.Copy

        '~~> Paste where you want
    End With
End Sub

另外，在粘贴文件之前请勿关闭该文件。粘贴时也必须小心。在粘贴之前将Copy 命令放在一行。有时剪贴板会被清除，您可能会遇到问题。