选择我的代码 - Excel悬挂着大量数据

Question

我正在从表1中的1列表中运行搜索键单词，并试图在表2中找到匹配项，表1和表2都有3000多个数据，我的代码搜索关键项目来自沿3000多行的1个单元格中的1个单元格，当找到匹配时，它将包含关键词的范围复制到新表格，并且还复制了表2中的匹配范围。从表1范围到新的表格和相邻的粘贴范围从表2进行。在此操作时，当这些数据巨大时，Excel挂起执行任务。以下是整个代码，我使用按钮

调用amate((子例程

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

Answer 1

我为练习做了这一点，这就是我的做法：

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