我希望通過結合使用陣列來加速 For 回圈（如下面的代碼）。非常感謝有關如何執行此操作的一些建議：
Sub DetectedCheck()
'counts rows in sheet 1 and 2.
With Sheets(1)
reconrows = .Range("a" & .Rows.Count).End(xlUp).Row
End With
'Checks that the new data has both an assigned and detected role and adds "No Issue" to column Q if valid.
For i = 2 To reconrows
If ActiveWorkbook.Sheets(1).Range("J" & i).Value <> "Not Found" And ActiveWorkbook.Sheets(1).Range("K" & i).Value <> "" Then
ActiveWorkbook.Sheets(1).Range("S" & i).Value = "No Issue"
End If
Next i
End Sub
uj5u.com熱心網友回復：
請嘗試下一個方法：
Sub DetectedCheck()
Dim sh As Worksheet, reconRows As Long, arrJK, arrS, i As Long
Set sh = Sheets(1)
reconRows = sh.Range("a" & sh.rows.count).End(xlUp).row
arrJK = sh.Range("J2:K" & reconRows).value
arrS = sh.Range("S2:S" & reconRows).value
'Checks that the new data has both an assigned and detected role and adds "No Issue" to column Q if valid.
For i = 1 To UBound(arrJK)
If arrJK(i, 1) <> "Not Found" And arrJK(i, 2) <> "" Then
arrS(i, 1) = "No Issue"
End If
Next i
sh.Range("S2").Resize(UBound(arrS), 1).value = arrS
End Sub
但是在代碼注釋中，您在Q 列中提到“沒有問題”，并且在您的代碼中您使用 S:S 列。如果必須在 Q:Q 中完成回傳，請進行調整。
uj5u.com熱心網友回復：
想要測驗這種方法并查看與行相比使用陣列回圈的速度嗎？
Dim timmy, i As Long, rc As Long, arr1, arr2, arr3
timmy = Timer
With Sheets(1)
rc = .Range("A" & Rows.Count).End(xlUp).Row
arr1 = .Range("J2:J" & rc).Value
arr2 = .Range("K2:K" & rc).Value
ReDim arr3(1 To UBound(arr1), 1 To 1)
For i = 1 To UBound(arr1, 1)
If arr1(i, 1) = "Not Found" And IsEmpty(arr2(i, 1)) Then
arr3(i, 1) = ""
Else
arr3(i, 1) = "No Issue"
End If
Next i
.Range("S2:S" & rc).Value = arr3
End With
Debug.Print "Loopy", Timer - timmy
uj5u.com熱心網友回復：
回圈遍歷陣列而不是范圍
- 要加速回圈，您可以關閉三個最常見的“速度相關”應用程式設定：ScreenUpdating、Calculation和EnableEvents。通常它沒有多大幫助。
- 訣竅是盡可能少地訪問作業表，即將范圍的值寫入陣列（您可以將這些二維單基陣列視為記憶體中的范圍（在本例中為列范圍），從第 1 行開始，因為它們的處理方式相似），回圈遍歷陣列并將結果寫入另一個（結果）陣列，并將后一個陣列中的值寫入結果范圍。
- 第一個代碼，陣列代碼，對 100.000 行簡單示例資料（使用該
PopulateRandomData程序創建）花費了大約 0.3 秒，導致大約 25.000個無問題單元格。 - 對于相同的資料，第二個代碼（范圍代碼）在先前清除結果（目標）列范圍時花費了大約 2.5 秒。如果在回圈中清除每個單元格（錯誤），大約需要 5 秒。如果
vbNullString或Empty被寫入回圈，則需要 40 秒（一個巨大的錯誤）。 - 因此，陣列代碼大約快 8 倍，但取決于您的資料以及之前撰寫代碼的方式，陣列代碼可能會快很多（數十甚至數百）倍。
- 請注意，您的資料的運行時間會有所不同，因此非常感謝您的反饋。
- 查看這些
Excel Macro Mastery videos以快速了解陣列及其用于加速代碼的用途。
Option Explicit
Sub DetectedCheckArray()
' Constants
Const wsID As Variant = 1 ' safer is to use the (tab) name, e.g. "Sheet1"
Const fRow As Long = 2
Const lrCol As String = "A" ' Last Row Column
Const c1Col As String = "J" ' 1st Criteria Column
Const c2Col As String = "K" ' 2nd Criteria Column
Const NotCrit1 As String = "Not Found" ' 1st Criteria
Const NotCrit2 As String = "" ' 2nd Criteria
Const dCol As String = "S" ' Destination Column
Const dString As String = "No Issue"
' If you use constants at the beginning of the code,
' you can easily change their values in one place without
' searching in the code.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws') (in the workbook).
Dim ws As Worksheet: Set ws = wb.Worksheets(wsID) '
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
' Calculate the number of rows ('rCount').
Dim rCount As Long: rCount = lRow - fRow 1
' Note that all ranges and arrays have this number of rows ('rCount').
' Validate the number of rows.
If rCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Reference the last row (one-column) range ('lrrg') to be used
' to easily reference the remaining ranges.
Dim lrrg As Range
' This may be more understandable (commonly used),...
Set lrrg = ws.Range(ws.Cells(fRow, lrCol), ws.Cells(lRow, lrCol))
' ... but I prefer:
'Set lrrg = ws.Cells(fRow, lrCol).Resize(rCount)
' Reference the criteria (one-column) ranges ('crg1' and 'crg2').
Dim crg1 As Range: Set crg1 = lrrg.EntireRow.Columns(c1Col)
Dim crg2 As Range: Set crg2 = lrrg.EntireRow.Columns(c2Col)
' If you have a reference to a one-column range ('lrrg') and you want
' to reference the same range in another worksheet column ('c1Col, c2Col'),
' use '.EntireRow' to easily do it, to not complicate with '.Offset'.
' The code so far runs in split seconds.
' The following is the improvement.
' Start measuring the time passed.
Dim dt As Double: dt = Timer
' Write the values from the criteria ranges
' to 2D one-based one-column arrays ('cData1' and 'cData2').
Dim cData1() As Variant
Dim cData2() As Variant
If rCount = 1 Then ' one cell
ReDim cData1(1 To 1, 1 To 1): cData1(1, 1) = crg1.Value
ReDim cData2(1 To 1, 1 To 1): cData1(1, 1) = crg2.Value
Else ' multiple cells
cData1 = crg1.Value
cData2 = crg2.Value
End If
' Define the destination string array ('dsData').
Dim dsData() As String: ReDim dsData(1 To rCount, 1 To 1)
Dim r As Long
' Loop through the rows ('r') of the arrays and for each row
' check the values of the criteria arrays against the (not) criterias.
' If all (both) conditions are met, write the destination string ('dString')
' to the current row of the destination string array.
For r = 1 To rCount
If StrComp(CStr(cData1(r, 1)), NotCrit1, vbTextCompare) <> 0 Then
If StrComp(CStr(cData2(r, 1)), NotCrit2, vbTextCompare) <> 0 Then
dsData(r, 1) = dString
End If
End If
Next r
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = lrrg.EntireRow.Columns(dCol)
' Write the values from the destination string array
' to the destination range.
drg.Value = dsData
' Inform.
MsgBox "Finished in " & Timer - dt & " seconds.", vbInformation
End Sub
Sub DetectedCheckRange()
' Constants
Const wsID As Variant = 1 ' safer is to use the (tab) name, e.g. "Sheet1"
Const fRow As Long = 2
Const lrCol As String = "A" ' Last Row Column
Const c1Col As String = "J" ' 1st Criteria Column
Const c2Col As String = "K" ' 2nd Criteria Column
Const NotCrit1 As String = "Not Found" ' 1st Criteria
Const NotCrit2 As String = "" ' 2nd Criteria
Const dCol As String = "S" ' Destination Column
Const dString As String = "No Issue"
' If you use constants at the beginning of the code,
' you can easily change their values in one place without
' searching in the code.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws') (in the workbook).
Dim ws As Worksheet: Set ws = wb.Worksheets(wsID) '
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
' Calculate the number of rows ('rCount').
Dim rCount As Long: rCount = lRow - fRow 1
' Note that all ranges and arrays have this number of rows ('rCount').
' Validate the number of rows.
If rCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Reference the last row (one-column) range ('lrrg') to be used
' to easily reference the remaining ranges.
Dim lrrg As Range
' This may be more understandable (commonly used),...
Set lrrg = ws.Range(ws.Cells(fRow, lrCol), ws.Cells(lRow, lrCol))
' ... but I prefer:
'Set lrrg = ws.Cells(fRow, lrCol).Resize(rCount)
' Reference the criteria (one-column) ranges ('crg1' and 'crg2').
Dim crg1 As Range: Set crg1 = lrrg.EntireRow.Columns(c1Col)
Dim crg2 As Range: Set crg2 = lrrg.EntireRow.Columns(c2Col)
' If you have a reference to a one-column range ('lrrg') and you want
' to reference the same range in another worksheet column ('c1Col, c2Col'),
' use '.EntireRow' to easily do it, to not complicate with '.Offset'.
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = lrrg.EntireRow.Columns(dCol)
' The code so far runs in split seconds.
' The following loop is what is slowing down the code.
' Start measuring the time passed.
Dim dt As Double: dt = Timer
' Turn off application settings to speed up.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
drg.ClearContents ' or drg.clear (2.5 seconds)
Dim r As Long
' Loop through the rows ('r') of the column ranges and for each row
' check the values of the criteria ranges against the (not) criterias.
' If all (both) conditions are met, write the destination string ('dString')
' to the current row of the destination column.
For r = 1 To rCount
If StrComp(CStr(crg1.Cells(r).Value), NotCrit1, vbTextCompare) <> 0 Then
If StrComp(CStr(crg2.Cells(r).Value), NotCrit2, vbTextCompare) _
<> 0 Then
drg.Cells(r).Value = dString
Else ' The following line may or may not be necessary.
' Mistake, clear the complete range before (5 seconds).
'drg.Cells(r).Clear ' Contents ' or drg.Cells(r).Clear
' Huge mistake, use clear instead (40 seconds).
'drg.Cells(r).Value = Empty
'drg.Cells(r).Value = vbNullString
End If
End If
Next r
' Turn on application settings.
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' Inform.
MsgBox "Finished in " & Timer - dt & " seconds.", vbInformation
End Sub
Sub PopulateRandomData()
Const rCount As Long = 100000
With ThisWorkbook.Worksheets(1)
.UsedRange.Clear
.Range("C:H,M:Q").EntireColumn.Hidden = True
With .Range("A2").Resize(rCount)
.Cells(1).Offset(-1).Value = "LrCol"
.Value = .Worksheet.Evaluate("ROW(1:" & CStr(rCount 1) & ")")
.EntireColumn.AutoFit
End With
With .Range("J2").Resize(rCount)
.Cells(1).Offset(-1).Value = "Criteria1"
.Formula = "=CHOOSE(RANDBETWEEN(1,2),""Found"",""Not Found"")"
.Value = .Value
.EntireColumn.AutoFit
End With
With .Range("K2").Resize(rCount)
.Cells(1).Offset(-1).Value = "Criteria2"
.Formula = "=CHOOSE(RANDBETWEEN(1,2),""String"","""")"
.Value = .Value
.EntireColumn.AutoFit
End With
With .Range("S1")
.Value = "Result No Issue"
.EntireColumn.AutoFit
End With
End With
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/497584.html
上一篇：VSCodeVetur擴展無法讀取帶有InertiaJS檔案的VueJS
下一篇：如何一次解密多條訊息？