[英]Improve Performance of VBA String Comparison
我想知道是否可以使用另一种技术来加速此代码。 该代码不会花费太长时间,但是看到通常需要多快才能操作某件东西,我很好奇是否可以提高它的速度。 该代码仅用于检查模板表中的每一列,以查看该值是否匹配,如果不匹配,则创建一个报告,以显示有关零件以及不正确/正确值的信息。
Option Explicit
'Check values of table against template table
Sub checkTemplate(shnam1 As Worksheet, shnam2 As Worksheet, shnam3 As Worksheet)
'Initalizes integers that will be used
Dim rwIndex As Long '"Item Attributes" row index
Dim colIndex As Long '"Item Attributes" column index
Dim rowEnd As Long 'Last row in "Item Attributes"
Dim colEnd As Long 'Last column in "Item Attributes"
Dim tempIndex As Integer
Dim resRow As Long 'Current row in "Report" to paste
Dim resCol As Long 'Current column in "Report" to paste
Dim temp1 As String
Dim temp2 As String
'Gets bounds for "Item Attributes" table
rowEnd = shnam1.Cells(Application.Rows.Count, 1).End(xlUp).Row
colEnd = shnam1.Cells(1, Application.Columns.Count).End(xlToLeft).Column
'Report Heading
shnam3.Cells(1, 1).Value = "Oracle Part Number"
shnam3.Cells(1, 2).Value = "Description"
shnam3.Cells(1, 3).Value = "Attribute Name"
shnam3.Cells(1, 4).Value = "Incorrect Value"
shnam3.Cells(1, 5).Value = "Correct Value"
resRow = 2 'Set row for Results
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'From 2nd row to last row
For rwIndex = 2 To rowEnd
tempIndex = 3 'Template table index
resCol = 1 'Set column for results
temp1 = shnam1.Cells(rwIndex, 1)
temp2 = shnam1.Cells(rwIndex, 2)
'From 3rd column to last column
For colIndex = 3 To colEnd
'Compare selection in data to template table
If (shnam1.Cells(rwIndex, colIndex).Value) <> (shnam2.Cells(tempIndex, 1).Value) Then
shnam3.Cells(resRow, resCol) = temp1
shnam3.Cells(resRow, resCol + 1) = temp2
'Copy attribute name
shnam2.Cells(tempIndex, 2).Copy shnam3.Cells(resRow, resCol + 2)
'Copy incorrect attribute value
shnam1.Cells(rwIndex, colIndex).Copy shnam3.Cells(resRow, resCol + 3)
'Copy correct attribute value
shnam2.Cells(tempIndex, 1).Copy shnam3.Cells(resRow, resCol + 4)
resRow = resRow + 1 'Move down a row in the "Report" table
End If
tempIndex = tempIndex + 1 'Increment through template table
Next colIndex
Next rwIndex
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
看看是否可以更快地运行:
Sub checkTemplate(shnam1 As Worksheet, shnam2 As Worksheet, shnam3 As Worksheet)
Dim lCalc As XlCalculation
Dim arrResults(1 To 65000, 1 To 5) As Variant
Dim arrTable() As Variant
Dim varCriteria As Variant
Dim rIndex As Long
Dim cIndex As Long
Dim ResultIndex As Long
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo CleanExit
arrTable = shnam1.Range("A1").CurrentRegion.Value
For rIndex = 2 To UBound(arrTable, 1)
For cIndex = 3 To UBound(arrTable, 2)
varCriteria = shnam2.Cells(cIndex, "A").Value
If arrTable(rIndex, cIndex) <> varCriteria Then
ResultIndex = ResultIndex + 1
arrResults(ResultIndex, 1) = arrTable(rIndex, 1)
arrResults(ResultIndex, 2) = arrTable(rIndex, 2)
arrResults(ResultIndex, 3) = shnam2.Cells(cIndex, "B").Text
arrResults(ResultIndex, 4) = arrTable(rIndex, cIndex)
arrResults(ResultIndex, 5) = varCriteria
End If
Next cIndex
Next rIndex
If ResultIndex > 0 Then
With shnam3.Range("A1:E1")
.Value = Array("Oracle Part Number", "Description", "Attribute Name", "Incorrect Value", "Correct Value")
.Font.Bold = True
End With
shnam3.Range("A2:E2").Resize(ResultIndex).Value = arrResults
shnam3.Range("A1").CurrentRegion.Sort shnam3.Range("A1"), xlAscending, Header:=xlYes
shnam3.Range("A:E").EntireColumn.AutoFit
End If
CleanExit:
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
If Err.Number <> 0 Then
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
Erase arrResults
Erase arrTable
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.