我正在开发一个程序,将数据从一个工作簿复制到另一个工作簿,跳过 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
尝试将
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
您可以更改为变体数组方法。
类似这样的事情。
注意:我做了其他各种小改动来整理你的代码
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
我发现删除未使用的模块对我来说很有效。
代码
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