我正在从工作表1的1个列表中运行搜索关键字，并尝试在工作表2中找到匹配项，工作表1和工作表2都具有3000+数据，我的代码从工作表2的1个单元格中搜索关键字项沿着3000多个行查找匹配项时，它将包含关键字的范围复制到新的工作表中，并且还将匹配范围复制到工作表2中。现在，这对于每个订单项都是递归的，它会从工作表1范围进行精确复制到新工作表并相邻粘贴工作表2的范围。在执行此操作时，当此数据很大时，excel将挂起执行任务。下面是完整的代码，我使用按钮调用Match（）子例程
Function GetText(CellRef As String)
Dim StringLength As Integer
StringLength = Len(CellRef)
For i = 1 To StringLength
If Not (IsNumeric(Mid(CellRef, i, 1))) Then Result = Result & Mid(CellRef, i, 1)
Next i
GetText = Result
End Function
Sub MATCH()
Dim curAddress, curAddress2 As Variant
Dim DMD As Variant
Dim P As Variant
Dim curSkill, curDRoleDesc, curPRoleDesc, curDLoc, curPLoc As String
Dim insert_FLAG As String
Dim tempSKILL As String
Dim multSkill() As String
Dim lContinue As Long
Application.EnableCancelKey = xlErrorHandler
On Error GoTo ErrHandler
Sheets("M_DEM").Activate
Sheet1.Range("A4").Select
Do Until IsEmpty(ActiveCell)
curAddress = ActiveCell.Offset.Address
DMD = Range(Range(ActiveCell.Offset.Address), Range(ActiveCell.Offset.Address).End(xlToRight)).Copy
'curSkill = Replace(ActiveCell.Offset(0, 23), "(", " ", 4)
curSkill = Trim(Left(ActiveCell.Offset(0, 22), InStr(ActiveCell.Offset(0, 22), "(") - 1))
curDRoleDesc = ActiveCell.Offset(0, 24)
curDLoc = ActiveCell.Offset(0, 25)
Sheets("M_P").Activate
Sheet2.Range("A2").Select
Do Until IsEmpty(ActiveCell)
curAddress2 = ActiveCell.Offset.Address
tempSKILL = Trim(Replace(Replace(ActiveCell.Offset(0, 22), "(", ""), ")", ""))
tempSKILL = GetText(tempSKILL)
curPRoleDesc = ActiveCell.Offset(0, 24)
curPLoc = ActiveCell.Offset(0, 6)
multSkill = Split(tempSKILL, ",")
For i = LBound(multSkill()) To UBound(multSkill())
insert_FLAG = "N"
If UCase(Trim(multSkill(i))) = UCase(curSkill) Then
DMD = Range(Range(curAddress), Range(curAddress).End(xlToRight)).Copy
Call INS_map_demand(DMD, insert_FLAG)
insert_FLAG = "S"
P = Sheet2.Range(Sheet2.Range(curAddress2), Sheet2.Range(curAddress2).End(xlToRight)).Copy
Call INS_map_demand(P, insert_FLAG)
Sheet3.Range(ActiveCell.Offset.Address).End(xlToRight).Select
ActiveCell.Offset(0, 1) = "1"
'If Mapping1.chkbox1 = "Y" Then
If curPRoleDesc = curDRoleDesc Then
ActiveCell.Offset(0, 2) = "1"
Else
ActiveCell.Offset(0, 2) = "0"
End If
'Else
'ActiveCell.Offset(0, 2) = "0"
'End If
If UCase(curDLoc) = UCase(curPLoc) Then
ActiveCell.Offset(0, 3) = "1"
Else
ActiveCell.Offset(0, 3) = "0"
End If
End If
Next i
Sheets("M_P").Activate
Sheet2.Range(curAddress2).Select
ActiveCell.Offset(1, 0).Select
Loop
Sheets("M_DEM").Activate
Sheet1.Range(curAddress).Select
ActiveCell.Offset(1, 0).Select
Loop
Application.EnableCancelKey = xlInterrupt
Application.CutCopyMode = False
Application.DisplayAlerts = False
ErrHandler:
If Err.Number = 18 Then
lContinue = MsgBox("Do you want to Continue (YES)?" & vbCrLf & _
"Do you want to QUIT? [Click NO]", _
Buttons:=vbYesNo)
If lContinue = vbYes Then
Resume
Else
Application.EnableCancelKey = xlInterrupt
MsgBox ("Program ended at your request")
Exit Sub
End If
End If
Application.EnableCancelKey = xlInterrupt
End Sub
Sub INS_map_dem(DMD As Variant, FLAG As String)
Sheets("Map_PD").Activate
Sheet3.Range("A1").Select
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
If FLAG = "S" Then
Sheet3.Range(ActiveCell.Offset(-1, 0).Address).Select
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Select
Loop
End If
ActiveSheet.Paste
End Sub
答案 0 :(得分：0)
我是为练习而这样做的，这是我的做法：
Sub tgr()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim wsDEM As Worksheet: Set wsDEM = wb.Worksheets("M_DEM")
Dim wsP As Worksheet: Set wsP = wb.Worksheets("M_P")
Dim wsPD As Worksheet: Set wsPD = wb.Worksheets("Map_PD")
Dim aDEM As Variant
With wsDEM.Range("A4", wsDEM.Cells(wsDEM.Rows.Count, "A").End(xlUp)).Resize(, wsDEM.Range("A4").CurrentRegion.Columns.Count)
If .Row < 4 Then Exit Sub 'No data
aDEM = .Value
End With
Dim aP As Variant
With wsP.Range("A2", wsP.Cells(wsP.Rows.Count, "A").End(xlUp)).Resize(, wsP.Range("A2").CurrentRegion.Columns.Count)
If .Row < 2 Then Exit Sub 'No data
aP = .Value
End With
Dim aResults() As Variant: ReDim aResults(1 To 65000, 1 To UBound(aDEM, 2) + UBound(aP, 2) + 3)
Dim ixResult As Long: ixResult = 0
Dim vSkill As Variant
Dim sDEMSkill As String
Dim ixDEM As Long, ixP As Long, ixCol As Long
For ixDEM = 1 To UBound(aDEM, 1)
If (ixDEM - 1) Mod 20 = 0 Then
DoEvents
Application.StatusBar = "Processing, " & Format(ixDEM / UBound(aDEM, 1), "0.00%")
End If
'Define skill from wsDEM to compare against
sDEMSkill = Trim(Left(aDEM(ixDEM, 23), InStr(1, aDEM(ixDEM, 23) & "(", "(", vbTextCompare) - 1))
For ixP = 1 To UBound(aP, 1)
'Compare each comma-delimited skill from wsP against the DEM Skill to find matches
'Remove the parentheses and numeric characters from the comma delimited list
For Each vSkill In Split(GetText(Trim(Replace(Replace(aP(ixP, 23), "(", ""), ")", ""))), ",")
'Check if the current wsP skill matches the DEM Skill
If UCase(Trim(vSkill)) = UCase(sDEMSkill) Then
'Match found, populate new row for results
ixResult = ixResult + 1
'Get all columns from both sheets from matching rows
For ixCol = 1 To UBound(aDEM, 2) + UBound(aP, 2)
Select Case (ixCol > UBound(aDEM, 2))
Case True: aResults(ixResult, ixCol) = aP(ixP, ixCol - UBound(aDEM, 2))
Case Else: aResults(ixResult, ixCol) = aDEM(ixDEM, ixCol)
End Select
Next ixCol
'Result col 3rd from end should be: 1
aResults(ixResult, UBound(aResults, 2) - 2) = 1
'Check if RoleDesc is the same, populate col 2nd from end
Select Case (UCase(Trim(aDEM(ixDEM, 25))) = UCase(Trim(aP(ixP, 25))))
Case True: aResults(ixResult, UBound(aResults, 2) - 1) = 1
Case Else: aResults(ixResult, UBound(aResults, 2) - 1) = 0
End Select
'Check if Loc is the same, populate end col
Select Case (UCase(Trim(aDEM(ixDEM, 26))) = UCase(Trim(aP(ixP, 7))))
Case True: aResults(ixResult, UBound(aResults, 2)) = 1
Case Else: aResults(ixResult, UBound(aResults, 2)) = 0
End Select
If ixResult = UBound(aResults, 1) Then OutputResults wsPD, aResults, ixResult
End If
Next vSkill
Next ixP
Next ixDEM
'If matches were found, output results
If ixResult > 0 Then OutputResults wsPD, aResults, ixResult
Application.StatusBar = vbNullString
End Sub
Function GetText(ByVal arg_sText As String) As String
Dim sTemp As String
Dim sResult As String
Dim i As Long
For i = 1 To Len(arg_sText)
sTemp = Mid(arg_sText, i, 1)
If Not (IsNumeric(sTemp)) Then sResult = sResult & sTemp
Next i
GetText = sResult
End Function
Sub OutputResults(ByRef arg_ws As Worksheet, ByRef arg_aResults As Variant, arg_ixResult As Long)
Static wsDest As Worksheet
If wsDest Is Nothing Then Set wsDest = arg_ws
'Check if results will exceed the number of rows available on the output sheet
If (wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1 + arg_ixResult) > wsDest.Rows.Count Then
'Rows exceeded, create new output sheet to continue on
Set wsDest = wsDest.Parent.Worksheets.Add(After:=wsDest)
End If
'Output currently stored results
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(arg_ixResult, UBound(arg_aResults, 2)).Value = arg_aResults
Dim lRowMax As Long: lRowMax = UBound(arg_aResults, 1)
Dim lColMax As Long: lColMax = UBound(arg_aResults, 2)
Erase arg_aResults
ReDim arg_aResults(1 To lRowMax, 1 To lColMax)
arg_ixResult = 0
End Sub