查找代码求斧正、提速

wowo000

各位老师：打搅午休，恳请斧正俺附件里的代码且使之提速（现有代码用于十万行以上就很卡），谢谢！

wowo000

各位老师：俺就本贴求助补充一下，即：“计费”表里的红色字体内容，C列着黄色起初是没有的。
先清空“计费”表里的红色字体内容，清除C列着黄色，然后用代码一气呵成未清理之前的红色字体内容及C列是副单号着黄色效果（也就是附件里现有代码运行出来的效果）。有劳哪位老师帮忙，多谢！！！

smiletwo

          用字典吧，查找效率高点。但涉及单元格标色，快不了太多

wowo000

smiletwo 发表于 2023-2-23 12:42
用字典吧，查找效率高点。但涉及单元格标色，快不了太多

smiletwo老师：辛苦您给整整？？谢谢！

cjc209

可以这样不?
Sub 查号匹对()
    Dim Arr, Brr, x&, i&, R&, irow, Rng As Range
    Sheets("计费").[J5:M9999] = Empty
    Arr = Sheets("计费").Range("A5:M" & Sheets("计费").Range("C" & Rows.Count).End(xlUp).Row)
    Brr = Sheets("系统数据").UsedRange
    Tim = Timer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    For x = 1 To UBound(Arr)
        For i = 2 To UBound(Brr)
            If InStr(Brr(i, 13), Arr(x, 3)) Then
                Arr(x, 2) = Brr(i, 1)
                Arr(x, 5) = Brr(i, 5)
                Arr(x, 12) = Brr(i, 13)
                Arr(x, 13) = Brr(i, 2)
                If Rng Is Nothing Then
                    Set Rng = Sheets("计费").Range("c" & x + 4)
                Else
                    Set Rng = Union(Rng, Sheets("计费").Range("c" & x + 4))
                End If
            End If
        Next
    Next
    Sheets("计费").Range("A5").Resize(UBound(Arr), 13) = Arr
    Rng.Interior.Color = 65535
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox Format(Timer - Tim, "0.00")
End Sub

excel玉米

wxxydl

Option Explicit
Sub 查号匹对1()
    Dim strs As String, ar
    Dim Arr, Brr, x&, i&, R&, irow, j&
    Dim ilastrow&, sht As Worksheet
    Dim dic As Object
    Dim Tim As Single
    Dim rng As Range
    Tim = Timer
    Set dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Set sht = Sheets("计费")
    With sht
        ilastrow = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
        .[J5:M9999] = Empty
        Arr = .Range("A5:M" & ilastrow)
    End With
    For i = 1 To UBound(Arr)
        dic(Arr(i, 3)) = i
    Next
    Brr = Sheets("系统数据").UsedRange
    For i = 2 To UBound(Brr)
        If dic.exists(Brr(i, 2)) Then
            x = dic(Brr(i, 2))
            Arr(x, 2) = Brr(i, 1)
            Arr(x, 5) = Brr(i, 5)
            Arr(x, 12) = Brr(i, 13)
        End If
        If Len(Brr(i, 13)) Then
            ar = Split(Brr(i, 13), ",")
            For j = 0 To UBound(ar)
                If Len(ar(j)) And dic.exists(ar(j)) Then
                    x = dic(ar(j))
                    Arr(x, 12) = Brr(i, 13)
                    Arr(x, 13) = Brr(i, 2)
                    strs = strs & x + 4 & ","
                    'Exit For
                End If
            Next
        End If
    Next
    With sht
        .Range("A5").Resize(UBound(Arr), 13) = Arr
        strs = Left(strs, Len(strs) - 1)
        ar = Split(strs, ",")
        For i = 0 To UBound(ar)
            If rng Is Nothing Then
                Set rng = .Cells(ar(i), 3)
            Else
                Set rng = Union(rng, .Cells(ar(i), 3))
            End If
        Next
        If Not rng Is Nothing Then rng.Interior.Color = RGB(255, 255, 0)
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox Format(Timer - Tim, "0.00")
End Sub

wxxydl

看一下   应快一点

smiletwo

wowo000 发表于 2023-2-23 12:50
smiletwo老师：辛苦您给整整？？谢谢！

wowo000

楼上各位老师：今日鲜花冇了，改天奉上，谢谢各位的帮助！！！

wowo000

smiletwo 发表于 2023-2-23 14:16

smiletwo老师：这句 arr(i, 12) = brr(m, 13)提示越界？？有劳修正，谢谢！