[已解决]我想在这个EXCEL VBA中多加一个条件，可以做到吗？

JOB007

具体在EXCEL里面说明了，麻烦大神们了。

最佳答案

月排行榜 / 总排行榜

青城山苦丁茶

2014-1-3 14:11

改的，看成不：
Sub kkk()
    Dim d As Object, arr As Variant, i&, j&, a As Variant, theStr$
    Set d = CreateObject("Scripting.Dictionary")
    With Sheet1
        .Cells(1).CurrentRegion.Interior.ColorIndex = xlNone
        .Columns(5).Clear
        MsgBox "单击以继续……", vbInformation, "提示"
        arr = .Cells(1).CurrentRegion
        For i = 2 To UBound(arr)
            theStr = arr(i, 2)
            If theStr <> "" Then
                If InStr(arr(i, 2), "/") Then
                  a = Split(theStr & "/", "/")
                  a(UBound(a)) = theStr
                Else
                  a = Split(theStr, "/")
                End If
                For j = UBound(a) To 0 Step -1
                    a(j) = a(j) & arr(i, 4)
                    If d.Exists(a(j)) Then
                        .Cells(d(a(j)), 5) = "相同"
                        .Range(.Cells(d(a(j)), 4), .Cells(d(a(j)), 5)).Interior.ColorIndex = 6
                        .Cells(d(a(j)), 2).Interior.ColorIndex = 6
                        .Cells(i, 5) = "相同"
                        .Range(.Cells(i, 4), .Cells(i, 5)).Interior.ColorIndex = 6
                        .Cells(i, 2).Interior.ColorIndex = 6
                    Else
                       d(a(j)) = i
                    End If
                Next j
            End If
        Next i
    End With
    Set d = Nothing
End Sub
另：18行不是与5行合规则吗？为什么不相同呢？

跳转到最佳答案楼层

hwc2ycy

1. Sub kkk()
   
2.     Dim d As Object, arr As Variant, i&, j&, a As Variant, theStr$, theStr1$, theStr2$
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheet1
   
5.         .Cells.Interior.ColorIndex = xlNone
   
6.         .Columns(5).Clear
   
7.         MsgBox "单击以继续……", vbInformation, "提示"
   
8.         arr = .Cells(1).CurrentRegion
   
9.         For i = 2 To UBound(arr)
   
10.             theStr = arr(i, 2)
    
11.             If theStr <> "" Then
    
12.                 a = Split(theStr, "/")
    
13.                 If UBound(a) = 0 Then
    
14.                     d(a(0)) = i
    
15.                 End If
    
16.                 theStr = theStr & arr(i, 4)
    
17.                 If Not d.Exists(theStr) Then
    
18.                     d(theStr) = i
    
19.                     theStr = ""
    
20.                     For j = UBound(a) To 0 Step -1
    
21.                         If theStr = "" Then
    
22.                             theStr = a(j)
    
23.                         Else
    
24.                             theStr = theStr & "/" & a(j)
    
25.                             theStr = theStr & arr(i, 4)
    
26.                             If Not d.Exists(theStr) Then
    
27.                                 d(theStr) = i
    
28.                                 
    
29.                             Else
    
30.                                 .Cells(d(theStr), 5) = "相同"
    
31.                                 .Range(.Cells(d(theStr), 4), .Cells(d(theStr), 5)).Interior.ColorIndex = 6
    
32.                                 .Cells(d(theStr), 2).Interior.ColorIndex = 6
    
33.                                 .Cells(i, 5) = "相同"
    
34.                                 .Range(.Cells(i, 4), .Cells(i, 5)).Interior.ColorIndex = 6
    
35.                                 .Cells(i, 2).Interior.ColorIndex = 6
    
36.                             End If
    
37.                         End If
    
38.                     Next j
    
39.                 Else
    
40.                     .Cells(d(theStr), 5) = "相同"
    
41.                     .Range(.Cells(d(theStr), 4), .Cells(d(theStr), 5)).Interior.ColorIndex = 6
    
42.                     .Cells(d(theStr), 2).Interior.ColorIndex = 6
    
43.                     .Cells(i, 5) = "相同"
    
44.                     .Range(.Cells(i, 4), .Cells(i, 5)).Interior.ColorIndex = 6
    
45.                     .Cells(i, 2).Interior.ColorIndex = 6
    
46.                 End If
    
47.             End If
    
48.         Next i
    
49.     End With
    
50.     Set d = Nothing
    
51. End Sub

复制代码

hwc2ycy

就在   a = Split(theStr, "/") 下面加了三行而已。
      If UBound(a) = 0 Then
             d(a(0)) = i
      End If

JOB007

hwc2ycy 发表于 2014-1-3 09:34
就在   a = Split(theStr, "/") 下面加了三行而已。
      If UBound(a) = 0 Then
             d(a(0))  ...

不行啊，还是和之前的一样

hwc2ycy

颜色没变么？

hwc2ycy

对于你现有的附件，测试效果是对的。

青城山苦丁茶

改的，看成不：
Sub kkk()
    Dim d As Object, arr As Variant, i&, j&, a As Variant, theStr$
    Set d = CreateObject("Scripting.Dictionary")
    With Sheet1
        .Cells(1).CurrentRegion.Interior.ColorIndex = xlNone
        .Columns(5).Clear
        MsgBox "单击以继续……", vbInformation, "提示"
        arr = .Cells(1).CurrentRegion
        For i = 2 To UBound(arr)
            theStr = arr(i, 2)
            If theStr <> "" Then
                If InStr(arr(i, 2), "/") Then
                  a = Split(theStr & "/", "/")
                  a(UBound(a)) = theStr
                Else
                  a = Split(theStr, "/")
                End If
                For j = UBound(a) To 0 Step -1
                    a(j) = a(j) & arr(i, 4)
                    If d.Exists(a(j)) Then
                        .Cells(d(a(j)), 5) = "相同"
                        .Range(.Cells(d(a(j)), 4), .Cells(d(a(j)), 5)).Interior.ColorIndex = 6
                        .Cells(d(a(j)), 2).Interior.ColorIndex = 6
                        .Cells(i, 5) = "相同"
                        .Range(.Cells(i, 4), .Cells(i, 5)).Interior.ColorIndex = 6
                        .Cells(i, 2).Interior.ColorIndex = 6
                    Else
                       d(a(j)) = i
                    End If
                Next j
            End If
        Next i
    End With
    Set d = Nothing
End Sub
另：18行不是与5行合规则吗？为什么不相同呢？

JOB007

hwc2ycy 发表于 2014-1-3 13:44
颜色没变么？

不是啊，11行和18行都有YC152，但后面都没有显示“相同”并变黄色底啊。

JOB007

青城山苦丁茶 发表于 2014-1-3 14:11
改的，看成不：
Sub kkk()
    Dim d As Object, arr As Variant, i&, j&, a As Variant, theStr$

你的好像可以啊

hwc2ycy

JOB007 发表于 2014-1-3 15:11
不是啊，11行和18行都有YC152，但后面都没有显示“相同”并变黄色底啊。

11行和18行的没仔细看