VBA Excel 程序对某些人来说很慢，对另一些人来说很快

问题描述 投票：0回答：4

我正在开发一个程序，将数据从一个工作簿复制到另一个工作簿，跳过 F 列中不包含某些值的行。一切对我和我的一些同事来说都很完美（运行时间不到 5 秒），但对于其他人来说，运行时间需要 1 分钟以上。有什么原因可能会发生这种情况吗？这是我当前的代码，谢谢：

Sub ImportForecastData()

    Application.StatusBar = "Importing Data..."
    
    Dim sourceFilename As String, sFileName As String
    Dim sourceWorkbook As Workbook, importWorkbook As Workbook
    Dim filePath As String
    Dim openBefore As Boolean
    openBefore = False
    sFileName = "redactedName.xlsm"
    filePath = "F:\Redacted\redactedName.xlsm"
    
    Set importWorkbook = Application.ActiveWorkbook
    
    On Error Resume Next
    
        TestStr = Dir(filePath)
        
    On Error GoTo 0
    
    If TestStr = "" Then
        
    Else
    
        ' Only open workbook if closed, otherwise re-open is not needed, and will slow down refresh.
        If AlreadyOpen(sFileName) Then
            Set sourceWorkbook = Workbooks(sFileName)
            openBefore = True
        Else
            Set sourceWorkbook = Application.Workbooks.Open(filePath)
        End If
        
    
        ' copy data from source to this workbook
        Dim thisSheet As Worksheet
        Set thisSheet = importWorkbook.Worksheets(1)
        Dim sourceSheet As Worksheet
        Set sourceSheet = sourceWorkbook.Worksheets(1)
        
        ' clear previous data
        thisSheet.Range("A4:J198").ClearContents
        
        Dim iNumOfRows As Integer, iStartFromRow As Integer, currentRow As Integer
        iNumOfRows = sourceSheet.Range("A4").End(xlDown).Row '- counts used rows starting from A4
        
        For iStartFromRow = 4 To iNumOfRows
        
            If (sourceSheet.Cells(iStartFromRow, "F").Value) = "redacted" Or (sourceSheet.Cells(iStartFromRow, "F").Value) = "redacted2" Or (sourceSheet.Cells(iStartFromRow, "F").Value) = "redacted3" Then
    
                currentRow = thisSheet.Cells(iStartFromRow, "A").End(xlUp).Offset(1, 0).Row
                thisSheet.Cells(currentRow, "A").Value = sourceSheet.Cells(iStartFromRow, "A").Value
                thisSheet.Cells(currentRow, "B").Value = sourceSheet.Cells(iStartFromRow, "B").Value
                thisSheet.Cells(currentRow, "C").Value = sourceSheet.Cells(iStartFromRow, "C").Value
                thisSheet.Cells(currentRow, "D").Value = sourceSheet.Cells(iStartFromRow, "D").Value
                thisSheet.Cells(currentRow, "E").Value = sourceSheet.Cells(iStartFromRow, "E").Value
                thisSheet.Cells(currentRow, "F").Value = sourceSheet.Cells(iStartFromRow, "F").Value
                thisSheet.Cells(currentRow, "G").Value = sourceSheet.Cells(iStartFromRow, "G").Value
                thisSheet.Cells(currentRow, "H").Value = sourceSheet.Cells(iStartFromRow, "H").Value
                
                ' Offset to skip non-redacted column in sourceSheet
                thisSheet.Cells(currentRow, "I").Value = sourceSheet.Cells(iStartFromRow, "J").Value
                thisSheet.Cells(currentRow, "J").Value = sourceSheet.Cells(iStartFromRow, "K").Value
    
            End If
        
        Next iStartFromRow

        ' Close source workbook if it was closed before Refresh, otherwise keep open for continued work.
        If openBefore = False Then
            sourceWorkbook.Close
        End If
        
        MsgBox ("Import Complete")
        
    End If
    Application.StatusBar = False
    ActiveWorkbook.Saved = True
    
End Sub

我还有这个小功能，可以检查 sourceWorkbook 是否打开，以避免重新打开它。

Function AlreadyOpen(sFname As String) As Boolean

    Dim wkb As Workbook
    On Error Resume Next
    Set wkb = Workbooks(sFname)
    AlreadyOpen = Not wkb Is Nothing
    Set wkb = Nothing
    
End Function
excel vba
4个回答
0
投票

尝试将 

application.screenupdating = False
/ 
application.screenupdating = True
添加到您的代码中，如下所示。随着宏的进展，它将阻止屏幕更新，并有助于加快该过程。

Sub ImportForecastData()
    application.screenupdating = False
    Application.StatusBar = "Importing Data..."
    
    Dim sourceFilename As String, sFileName As String
    Dim sourceWorkbook As Workbook, thisWorkbook As Workbook
    Dim filePath As String
    Dim openBefore As Boolean
    openBefore = False
    sFileName = "redactedName.xlsm"
    filePath = "F:\Redacted\redactedName.xlsm"
    
    Set thisWorkbook = Application.ActiveWorkbook
    
    On Error Resume Next
    
        TestStr = Dir(filePath)
        
    On Error GoTo 0
    
    If TestStr = "" Then
        
    Else
    
        ' Only open workbook if closed, otherwise re-open is not needed, and will slow down refresh.
        If AlreadyOpen(sFileName) Then
            Set sourceWorkbook = Workbooks(sFileName)
            openBefore = True
        Else
            Set sourceWorkbook = Application.Workbooks.Open(filePath)
        End If
        
    
        ' copy data from source to this workbook
        Dim thisSheet As Worksheet
        Set thisSheet = thisWorkbook.Worksheets(1)
        Dim sourceSheet As Worksheet
        Set sourceSheet = sourceWorkbook.Worksheets(1)
        
        ' clear previous data
        thisSheet.Range("A4:J198").ClearContents
        
        Dim iNumOfRows As Integer, iStartFromRow As Integer, currentRow As Integer
        iNumOfRows = sourceSheet.Range("A4").End(xlDown).Row '- counts used rows starting from A4
        
        For iStartFromRow = 4 To iNumOfRows
        
            If (sourceSheet.Cells(iStartFromRow, "F").Value) = "redacted" Or (sourceSheet.Cells(iStartFromRow, "F").Value) = "redacted2" Or (sourceSheet.Cells(iStartFromRow, "F").Value) = "redacted3" Then
    
                currentRow = thisSheet.Cells(iStartFromRow, "A").End(xlUp).Offset(1, 0).Row
                thisSheet.Cells(currentRow, "A").Value = sourceSheet.Cells(iStartFromRow, "A").Value
                thisSheet.Cells(currentRow, "B").Value = sourceSheet.Cells(iStartFromRow, "B").Value
                thisSheet.Cells(currentRow, "C").Value = sourceSheet.Cells(iStartFromRow, "C").Value
                thisSheet.Cells(currentRow, "D").Value = sourceSheet.Cells(iStartFromRow, "D").Value
                thisSheet.Cells(currentRow, "E").Value = sourceSheet.Cells(iStartFromRow, "E").Value
                thisSheet.Cells(currentRow, "F").Value = sourceSheet.Cells(iStartFromRow, "F").Value
                thisSheet.Cells(currentRow, "G").Value = sourceSheet.Cells(iStartFromRow, "G").Value
                thisSheet.Cells(currentRow, "H").Value = sourceSheet.Cells(iStartFromRow, "H").Value
                
                ' Offset to skip non-redacted column in sourceSheet
                thisSheet.Cells(currentRow, "I").Value = sourceSheet.Cells(iStartFromRow, "J").Value
                thisSheet.Cells(currentRow, "J").Value = sourceSheet.Cells(iStartFromRow, "K").Value
    
            End If
        
        Next iStartFromRow

        ' Close source workbook if it was closed before Refresh, otherwise keep open for continued work.
        If openBefore = False Then
            sourceWorkbook.Close
        End If
        
        MsgBox ("Import Complete")
        
    End If
    Application.StatusBar = False
    ActiveWorkbook.Saved = True
    application.screenupdating = True

End Sub
0
投票

您可以更改为变体数组方法。

  1. 将源数据复制到数组。
  2. 为结果创建另一个数组。
  3. 循环源数组，用匹配的数据填充目标数组。
  4. 将目标数组放在工作表上。

类似这样的事情。
注意：我做了其他各种小改动来整理你的代码

Option Explicit ' Add this as the very first line in your module

Sub ImportForecastData()
    Application.StatusBar = "Importing Data..."
    
    Dim sourceFilename As String, sFileName As String
    Dim sourceWorkbook As Workbook, destWorkbook As Workbook
    Dim filePath As String
    Dim openBefore As Boolean
        
    openBefore = False
    sFileName = "redactedName.xlsm"
    filePath = "F:\Redacted\" & sFileName
    
    If Dir(filePath) <> vbNullString Then
        Set destWorkbook = Application.ActiveWorkbook
        ' Only open workbook if closed, otherwise re-open is not needed, and will slow down refresh.
        If AlreadyOpen(sFileName) Then
            Set sourceWorkbook = Workbooks(sFileName)
            openBefore = True
        Else
            Set sourceWorkbook = Application.Workbooks.Open(filePath)
        End If
    
        ' copy data from source to this workbook
        Dim thisSheet As Worksheet
        Set thisSheet = destWorkbook.Worksheets(1)
        Dim sourceSheet As Worksheet
        Set sourceSheet = sourceWorkbook.Worksheets(1)
        
        Dim sourceRange As Range
        Dim destRange As Range
        Dim sourceData As Variant
        Dim destData As Variant
        
        ' clear previous data
        thisSheet.Range("A4:J" & thisSheet.Rows.Count).ClearContents ' Assumes no other data below row 198
        Dim iSourceRow As Long, iDestRow As Long
        With sourceSheet
            Set sourceRange = .Range(.Cells(4, 1), .Cells(4, 1).End(xlDown)).Resize(, 11)
        End With
        Set destRange = thisSheet.Cells(4, 1)
        sourceData = sourceRange.Value2
        ReDim destData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2))
        
        iDestRow = thisSheet.Cells(thisSheet.Rows.Count, "A").End(xlUp).Row
        For iSourceRow = 1 To UBound(sourceData, 1)
            If sourceData(iSourceRow, 6) = "redacted" Or _
               sourceData(iSourceRow, 6) = "redacted2" Or _
               sourceData(iSourceRow, 6) = "redacted3" Then
                
                iDestRow = iDestRow + 1
                destData(iDestRow, 1) = sourceData(iSourceRow, 1)
                destData(iDestRow, 2) = sourceData(iSourceRow, 2)
                destData(iDestRow, 3) = sourceData(iSourceRow, 3)
                destData(iDestRow, 4) = sourceData(iSourceRow, 4)
                destData(iDestRow, 5) = sourceData(iSourceRow, 5)
                destData(iDestRow, 6) = sourceData(iSourceRow, 6)
                destData(iDestRow, 7) = sourceData(iSourceRow, 7)
                destData(iDestRow, 8) = sourceData(iSourceRow, 8)
                ' Offset to skip non-redacted column in sourceSheet
                destData(iDestRow, 9) = sourceData(iSourceRow, 10)
                destData(iDestRow, 10) = sourceData(iSourceRow, 11)
            End If
        Next iSourceRow
        
        Set destRange = destRange.Resize(UBound(destData, 1), UBound(destData, 2))
        destRange = destData
        ' Close source workbook if it was closed before Refresh, otherwise keep open for continued work.
        If Not openBefore Then
            sourceWorkbook.Close
        End If
        
        MsgBox ("Import Complete")
    End If
    Application.StatusBar = False
    destWorkbook.Save ' you ment to save the book, right?
    
End Sub
0
投票

我发现删除未使用的模块对我来说很有效。

-2
投票

从其他工作簿复制

代码

Option Explicit

Sub ImportForecastData()
    
    ' Source
    Const srcFullName As String = "F:\Test\redactedName.xlsm"
    Const srcName As String = "redactedName.xlsm"
    Const srcID As Variant = 1 ' e.g. 1,2,"Sheet1","Sheet2","Data" ...
    Const srcFirstRow As Long = 4
    Const srcLastRowCol As Long = 1
    Dim srcCols As Variant: srcCols = Array(1, 2, 3, 4, 5, 6, 7, 8, 10, 11)
    ' Target
    Const tgtID As Variant = 1 ' e.g. 1,2,"Sheet1","Sheet2","Data" ...
    Const tgtFirstCell As String = "A4"
    ' Other
    Const CritColIndex As Long = 5
    Dim Crit As Variant: Crit = Array("redacted", "redacted2", "redacted3")
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Change some application settings.
    Application.ScreenUpdating = False
    Application.StatusBar = "Importing Data..."
    
    ' Define Source Worksheet.
    Dim wbS As Workbook, wbWasNotOpen As Boolean
    On Error Resume Next
    Set wbS = Workbooks(srcName)
    If Err.Number = 9 Then
        wbWasNotOpen = True
        Set wbS = Workbooks.Open(srcFullName)
    End If
    On Error GoTo 0
    Dim src As Worksheet: Set src = wbS.Worksheets(srcID)
    
    ' Define Last Row Column Range.
    Dim rng As Range
    Set rng = src.Cells(src.Rows.Count, srcLastRowCol).End(xlUp)
    If rng.Row < srcFirstRow Then GoTo LastAboveFirst
    Set rng = src.Range(src.Cells(srcFirstRow, srcLastRowCol), rng)
    
    ' Write Source Columns to Source Jagged Array.
    Dim ubc As Long: ubc = UBound(srcCols)
    Dim Source As Variant: ReDim Source(ubc)
    Dim j As Long
    For j = 0 To ubc
        Source(j) = rng.Offset(, srcCols(j) - srcLastRowCol).Value
    Next j
    
    ' Write data from Source Array to Target Array.
    Dim ubs As Long: ubs = UBound(Source(0))
    Dim Target As Variant
    ReDim Target(1 To ubs, 1 To UBound(srcCols) + 1)
    Dim i As Long, k As Long
    For i = 1 To ubs
        If Not IsError(Application.Match(Source(CritColIndex)(i, 1), Crit, 0)) _
          Then
            k = k + 1
            For j = 0 To ubc
                Target(k, j + 1) = Source(j)(i, 1)
            Next j
        End If
    Next i
    
    ' Check if no criteria value was found.
    If k = 0 Then GoTo NoRedact
    
    ' Write data Target Array to Target Range.
    Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtID)
    Set rng = tgt.Range(tgtFirstCell).Resize(, ubc + 1)
    rng.Resize(tgt.Rows.Count - tgt.Range(tgtFirstCell).Row + 1).ClearContents
    rng.Resize(k).Value = Target
    wb.Save
        
    ' Inform user.
    MsgBox "Import Complete.", vbInformation
    
SafeExit:
    
    ' Close Source Workbook if it initially was not open.
    If wbWasNotOpen Then wbS.Close False ' False means without saving.
        
    ' Change (revert) some application settings.
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    Exit Sub
    
' Labels
LastAboveFirst:
    MsgBox "Last row is above first row."
    GoTo SafeExit

NoRedact:
    MsgBox "No data found"
    GoTo SafeExit
    
End Sub
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.