访问Excel VBA循环运行速度非常慢

Question

我在Access中有一个宏，它打开一个包含大约50个.csv文件的指定文件夹，一次打开一个文件，重新格式化它们，然后将它们复制并粘贴到主电子表格中。在每个.csv文件中，前三列是Project，Serial Number和Location。该信息在列的所有位置都是相同的（每个列的唯一值），并且运行需要很长时间。该位置是所有.csv文件的设定值，但序列号和位置随每个文件而变化。每个.csv文件都有相关的位置和序列号，所以基本上我只是指定范围并使用简单的For循环将范围内的每个值设置为单元格的值包含loc /序列号。

这是我的代码：

Sub RecursiveFolder(objFolder As Scripting.Folder, savePath As String)

    Dim xlApp As Excel.Application

    Dim objFile As Scripting.File
    Dim objSubFolder As Scripting.Folder
    Dim NextRow As Long

    'Do Stuff with each file in folders
    For Each objFile In objFolder.Files
        Set xlApp = New Excel.Application
        Dim wbData, wbMaster As Workbook
        xlApp.Visible = True
        Set wbMaster = xlApp.Workbooks.Open(savePath)
        Set wbData = xlApp.Workbooks.Open(objFile.Path)
        Dim masterSheet, curDataSheet As Worksheet
        Set masterSheet = wbMaster.Sheets(1)

        For Each sht In wbData.Sheets()
            Set curDataSheet = sht

            'Only want sheets with longer than 4 characters
            If Len(curDataSheet.Name) > 4 Then
                Dim lastRow As Long
                Dim masterLastRow As Long
                wbMaster.Activate
                masterSheet.Activate
                masterSheet.Cells(1, 1).Activate
                'masterLastRow = masterSheet.Rows.count("A")
                masterLastRow = masterSheet.Cells(masterSheet.Rows.Count, "A").End(xlUp).Row
                Dim cell1 As Boolean
                If masterSheet.Cells(1, 1).Value = "" Then
                cell1 = False
                Else
                cell1 = True
                End If

                wbData.Activate
                curDataSheet.Activate

                    lastRow = curDataSheet.Cells(curDataSheet.Rows.Count, "A").End(xlUp).Row

                                Dim bot, bot2, i As Integer
                                Dim rng, refrng As Range
                                Dim loc, sn As String

                                'Add first 3 and last 4 columns, give them titles
                                curDataSheet.Columns("A:C").Insert shift:=xlToRight
                                curDataSheet.Cells(12, 1).Value = "Project ID"
                                curDataSheet.Cells(12, 2).Value = "Serial_Number"
                                curDataSheet.Cells(12, 3).Value = "Location"
                                curDataSheet.Cells(12, 9).Value = "Date_Time"
                                curDataSheet.Cells(12, 10).Value = "DT Concat"
                                curDataSheet.Cells(12, 11).Value = "DT"
                                curDataSheet.Cells(12, 12).Value = "ST"

                                loc = curDataSheet.Cells(2, 4)
                                sn = curDataSheet.Cells(6, 4)

                                'define last row
                                bot = curDataSheet.Range("D" & curDataSheet.Rows.Count).End(xlUp).Row
                                'second bot pointer is bot -13 because of the extra 12 rows at the top
                                bot2 = bot - 12
                                'set ranges for loop
                                Set rng = curDataSheet.Range("A13:A" & bot)
                                Set refrng = curDataSheet.Range("D14:D" & bot)

                                'loop through ranges to set values
                                For i = 1 To bot2
                                    rng(i, 1).Value = "MSA DRA"
                                Next i

                                Set rng = curDataSheet.Range("B13:B" & bot)
                                For i = 1 To bot2
                                   rng(i, 1).Value = loc
                                Next i

                                Set rng = curDataSheet.Range("C13:C" & bot)
                                For i = 1 To bot2
                                   rng(i, 1).Value = sn
                                Next i

                                'Delete top 11 rows
                                curDataSheet.Rows("1:11").EntireRow.Delete

                Dim copyRange As Range

                If masterLastRow = 1 And Not cell1 Then

                    Set copyRange = curDataSheet.Range(curDataSheet.Cells(1, 1), curDataSheet.Cells(lastRow, 24))

                    copyRange.Copy

                Else

                    Set copyRange = curDataSheet.Range(curDataSheet.Cells(2, 1), curDataSheet.Cells(lastRow, 24))

                    copyRange.Copy

                End If

                wbData.Activate
                masterSheet.Activate
                Dim pasteRange As Range
                If masterLastRow = 1 Then


                     Set pasteRange = masterSheet.Range(masterSheet.Cells(1, 1), masterSheet.Cells(1, 1))
                    pasteRange.PasteSpecial xlPasteValues

                Else
                     Set pasteRange = masterSheet.Range(masterSheet.Cells(masterLastRow + 1, 1), masterSheet.Cells(masterLastRow + 1, 1))
                    pasteRange.PasteSpecial xlPasteValues

                End If
               End If
        Next sht

        wbMaster.Save
        wbMaster.Close
        wbData.Close savechanges:=False
        xlApp.Quit

    Next objFile

    'Recurse through subfolders

    For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder(objSubFolder, savePath)
    Next objSubFolder

End Sub

当我在Excel中执行此代码时，它立即运行，但是当我将它放在Access宏中并从那里运行时，它需要永远运行。想法？