查找代码求斧正、提速

wowo000

excel玉米 发表于 2023-2-23 13:55

excel玉米老师：您的代码和俺的代码运行得出效果不一致，您可能还没理解俺的意思，俺是想清空“计费”表里的红色字体内容，清除C列着黄色，然后用代码一气呵成出来未清理之前的红色字体内容及C列是副单号着黄色。有劳改改？？

wowo000

wxxydl 发表于 2023-2-23 14:06
看一下   应快一点

wxxydl老师：您的代码和俺的代码运行得出效果不一致，您可能还没理解俺的意思，俺是想清空“计费”表里的红色字体内容，清除C列着黄色，然后用代码一气呵成出来未清理之前的红色字体内容及C列是副单号着黄色（也就是俺的代码运行出来的效果）。有劳改改？？

smiletwo

wowo000 发表于 2023-2-23 14:49
smiletwo老师：这句 arr(i, 12) = brr(m, 13)提示越界？？有劳修正，谢谢！

看图，中间要用字符连起来，不然arr的维度值只能取到range（“A1:”)的连续非空列

wowo000

smiletwo 发表于 2023-2-23 15:08
看图，中间要用字符连起来，不然arr的维度值只能取到range（“A1:”)的连续非空列

smiletwo老师：谢谢您的回复！遗憾还是没有达到俺的VBA代码得出之效果，恳请再修正一下，多谢！！！

wowo000

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

smiletwo

wowo000 发表于 2023-2-23 15:35
smiletwo老师：谢谢您的回复！遗憾还是没有达到俺的VBA代码得出之效果，恳请再修正一下，多谢！！！

什么地方没达到效果？

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim crr() As Boolean
   
5.     Dim d As Object
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     Set d1 = CreateObject("scripting.dictionary")
   
10.     With Worksheets("系统数据")
    
11.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         brr = .Range("a2:m" & r)
    
13.         For i = 1 To UBound(brr)
    
14.             d(brr(i, 2)) = i
    
15.             If Len(brr(i, 13)) <> 0 Then
    
16.                 xm = Split(brr(i, 13), ",")
    
17.                 For j = 0 To UBound(xm)
    
18.                     d1(xm(j)) = i
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.     End With
    
23.     With Worksheets("计费")
    
24.         r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
25.         .Range("b5:b" & r & ",e5:e" & r & ",l5:m" & r).ClearContents
    
26.         .Range("c5:c" & r).Interior.ColorIndex = 0
    
27.         arr = .Range("a5:m" & r)
    
28.         ReDim crr(1 To UBound(arr), 1 To 1)
    
29.         For i = 1 To UBound(brr)
    
30.             If d.exists(arr(i, 3)) Then
    
31.                 m = d(arr(i, 3))
    
32.                 arr(i, 2) = brr(m, 1)
    
33.                 arr(i, 5) = brr(m, 5)
    
34.                 arr(i, 12) = brr(m, 13)
    
35.             ElseIf d1.exists(arr(i, 3)) Then
    
36.                 m = d1(arr(i, 3))
    
37.                 arr(i, 2) = brr(m, 1)
    
38.                 arr(i, 5) = brr(m, 5)
    
39.                 arr(i, 12) = brr(m, 13)
    
40.                 arr(i, 13) = brr(m, 2)
    
41.                 crr(i, 1) = True
    
42.             End If
    
43.         Next
    
44.         .Range("a5:m" & r) = arr
    
45.         For i = 1 To UBound(crr)
    
46.             If crr(i, 1) Then
    
47.                 .Cells(i + 4, 3).Interior.ColorIndex = 6
    
48.             End If
    
49.         Next
    
50.     End With
    
51. End Sub
    

复制代码

chxw68

参与一下。

wowo000

smiletwo 发表于 2023-2-23 15:51
什么地方没达到效果？

smiletwo老师：谢谢您的回复！俺要求您的代码效果和附件里已有代码两者得出效果一模一样。

准提部林

只想在C列標示"副单号"為黃色,
右方L/M列只是示例, 多餘???