Board logo

標題: [發問] 2儲存格中字串差異顯示 [打印本頁]
作者: free72921    時間: 2021-8-29 15:19     標題: 2儲存格中字串差異顯示

由於工作上偶爾會需要比對2儲存格中的字串差異，
字串數量龐大時非常傷眼，請問各位前輩是否有較
好的方式比對2儲存格中字串的差異並顯示出來。
感謝各位前輩


[attach]33955[/attach]
作者: samwang    時間: 2021-8-29 21:39

回復 1# free72921

請測試看看，謝謝

Sub test()
Dim xD, xD1, Ar(), Ar1(), T$, ky, L%, i&, j%, n%, n1%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
xR = Range("b3")
For j = 0 To UBound(Split(xR, ","))
    T = Split(xR, ",")(j): xD(T) = 1
Next
xR1 = Range("c3")
For j = 0 To UBound(Split(xR1, ","))
    T = Split(xR1, ",")(j): xD1(T) = 1
Next
For Each ky In xD
If xD1(ky) <> 1 Then: ReDim Preserve Ar(n): Ar(n) = ky: n = n + 1
Next
For Each ky In xD1
If xD(ky) <> 1 Then: ReDim Preserve Ar1(n1): Ar1(n1) = ky: n1 = n1 + 1
Next
If n1 > 0 Then
    For j = 0 To UBound(Ar1)
        T = Ar1(j): L = Len(T): pos = InStr(Range("c3"), T)
        Range("c3").Characters(pos, L).Font.ColorIndex = 3
    Next
End If
If n > 0 Then
    For j = 0 To UBound(Ar)
        T = Ar(j): L = Len(T): pos = InStr(Range("b3"), T)
        Range("b3").Characters(pos, L).Font.ColorIndex = 3
    Next
End If
End Sub
作者: ikboy    時間: 2021-8-29 21:56

回復 1# free72921
  1. Sub zz()
  2. Dim a(1), b, c, d, s$, j%, ln%
  3. a(0) = Split([b3].Value, ",")
  4. a(1) = Split([c3].Value, ",")
  5. For i = 0 To UBound(a)
  6.     If i Then n = 0 Else n = 1
  7.     b = a(i)
  8.     For Each c In a(n)
  9.         b = Filter(b, c, 0)
  10.     Next
  11.     If UBound(b) >= 0 Then
  12.         s = Cells(3, i + 2).Value
  13.         For Each c In b
  14.             ln = Len(c)
  15.             j = Application.WorksheetFunction.Find(c, s)
  16.             Cells(3, i + 2).Characters(j, ln).Font.Color = vbRed
  17.         Next
  18.     End If
  19. Next
  20. End Sub
複製代碼
作者: ML089    時間: 2021-8-29 22:15

Sub test()
    Set xB = [B3]
    Set xC = [C3]
    While xB <> ""
        If xB.Value <> xC.Value Then
            Call NotFindChar(xB, xC)
            Call NotFindChar(xC, xB)
        End If
        Set xB = xB(2, 1)
        Set xC = xC(2, 1)
    Wend
    Debug.Print "time", Time
End Sub

Sub NotFindChar(xC, xS)
    ArrC = Split(xC.Value, ",")
    For i = 0 To UBound(ArrC)
        If InStr("," & xS & ",", "," & ArrC(i) & ",") = 0 Then
            nS = InStr("," & xC & ",", "," & ArrC(i) & ",")
            nL = Len(ArrC(i))
            With xC.Characters(Start:=nS, Length:=nL).Font
                .FontStyle = "粗體"
                .Color = vbRed '紅色 -16777024
            End With
        End If
    Next
End Sub
作者: samwang    時間: 2021-8-30 07:27

本帖最後由 samwang 於 2021-8-30 07:30 編輯

請教各位大大，如果同時有2個以上的差異，後學目前只能將第1個差異反顏色(2#程式碼)，
不知各位大大是否可以將其他的差異也一併反顏色? 感謝
如附圖，第2個R777要反顏色。
作者: free72921    時間: 2021-8-30 09:29

感謝各位前輩幫忙，三位前輩的程式都可以比對出差異。
但2樓前輩的程式只會跑出第一個差異，後續再有差異則無法顯示，
另外2位前輩的程式都可以顯示出每一個差異點。

另有一事相求，像這樣的字串差異是否有可能以另一種方式執行，
因為每次比對時會有多個儲存格同時進行。

例如：
跳出詢問視窗【請選擇範圍A】
跳出詢問視窗【請選擇範圍B】
再以被選定的2個範圍開始進行比對
感謝各位前輩

[attach]33957[/attach]
作者: hcm19522    時間: 2021-8-30 09:33

https://blog.xuite.net/hcm19522/twblog/589988519
作者: ikboy    時間: 2021-8-30 10:43

回復 6# free72921
  1. Sub zz()
  2. Dim a(1), b, c, d, s$, j%, ln%
  3. a(0) = Split([b3].Value, ",")
  4. a(1) = Split([c3].Value, ",")
  5. Set d = CreateObject("scripting.dictionary")
  6. For i = 0 To UBound(a)
  7.     If i Then n = 0 Else n = 1
  8.     For Each c In a(i)
  9.         d(c) = ""
  10.     Next
  11.     s = Cells(3, i + 2).Value
  12.     For Each c In a(n)
  13.         If Not d.exists(c) Then
  14.             ln = Len(c)
  15.             j = InStr(s, c)
  16.             Cells(3, i + 2).Characters(j, ln).Font.Color = vbRed
  17.         End If
  18.     Next
  19.     d.RemoveAll
  20. Next
  21. End Sub
複製代碼
作者: ML089    時間: 2021-8-30 10:54

回復 5# samwang
你比較細心，確實有可能2個號碼在前後不同地方

我原先程式修改位置 *1 *2 *3
Sub test()
    ' 清除字顏色及粗體
    With Range("B3:C" & [C65536].End(xlUp).Row).Font
        .ColorIndex = xlAutomatic
        .Bold = False
    End With
   
    Set xB = [b3]
    Set xC = [c3]
    While xB <> ""
        If xB.Value <> xC.Value Then
            Call NotFindChar(xB, xC)
            Call NotFindChar(xC, xB)
        End If
        Set xB = xB(2, 1)
        Set xC = xC(2, 1)
    Wend
    Debug.Print "time", Time
End Sub

Sub NotFindChar(xC, xS)
    ArrC = Split(xC.Value, ",")
    nStart = 1 '*1
    For i = 0 To UBound(ArrC)
        If InStr("," & xS & ",", "," & ArrC(i) & ",") = 0 Then
            nS = InStr(nStart, "," & xC & ",", "," & ArrC(i) & ",") '*2
            nL = Len(ArrC(i))
            ' Range("b3").Characters(pos, L).Font.ColorIndex = 3
            ' Cells(3, i + 2).Characters(j, ln).Font.Color = vbRed
            With xC.Characters(Start:=nS, Length:=nL).Font
                .FontStyle = "粗體"
                .Color = vbRed '紅色 -16777024
            End With
        End If
        nStart = nStart + nL + 1 '*3
    Next
End Sub
作者: samwang    時間: 2021-8-30 11:42

本帖最後由 samwang 於 2021-8-30 11:45 編輯

回復 9# ML089

我是很粗心的人，只是剛好看到此問題，
另外，看到版主解答，也學習一下而想到解法，感謝。

Sub test()
Dim xD, xD1, Ar(), Ar1(), T$, ky, L%, i&, j%, n%, n1%, xP%, xP1
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
xR = Range("b3")
For j = 0 To UBound(Split(xR, ","))
    T = Split(xR, ",")(j): xD(T) = xD(T) + 1
Next
xR1 = Range("c3")
For j = 0 To UBound(Split(xR1, ","))
    T = Split(xR1, ",")(j): xD1(T) = xD1(T) + 1
Next
For Each ky In xD
If Not xD1.exists(ky) Then: ReDim Preserve Ar(n): Ar(n) = ky: n = n + 1
Next
For Each ky In xD1
If Not xD.exists(ky) Then: ReDim Preserve Ar1(n1): Ar1(n1) = ky: n1 = n1 + 1
Next
If n1 > 0 Then
    For j = 0 To UBound(Ar1)
        T = Ar1(j): L = Len(T)
        For j1 = 1 To xD1(T)
            If j1 = 1 Then
                pos = InStr(Range("c3"), T)
            Else
                pos = InStr(xP, Range("c3"), T)
            End If
            Range("c3").Characters(pos, L).Font.ColorIndex = 3
            xP = pos + 2
        Next
    Next
End If
If n > 0 Then
    For j = 0 To UBound(Ar)
        T = Ar(j): L = Len(T)
        For j1 = 1 To xD(T)
            If j1 = 1 Then
                pos = InStr(Range("b3"), T)
            Else
                pos = InStr(xP1, Range("b3"), T)
            End If
            Range("b3").Characters(pos, L).Font.ColorIndex = 3
            xP1 = pos + 2
        Next
    Next
End If
End Sub
作者: samwang    時間: 2021-8-30 14:28

本帖最後由 samwang 於 2021-8-30 14:31 編輯

回復 6# free72921

例如：
跳出詢問視窗【請選擇範圍A】
跳出詢問視窗【請選擇範圍B】
再以被選定的2個範圍開始進行比對
>> 如下，請測試看看，謝謝

Sub test2()
Dim R, xR, xR1, xD, xD1, Ar(), Ar1(), ky
Dim T$, L%, i&, j%, n%, n1%, xP%, xP1%, pos%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
On Error Resume Next
Set xR = Application.InputBox("請選擇Range:", Type:=8)
Set xR1 = Application.InputBox("請選擇Range:", Type:=8)

For Each R In xR: For j = 0 To UBound(Split(R, ","))
    T = Split(R, ",")(j): xD(T) = xD(T) + 1
Next j: Next R
For Each R In xR1: For j = 0 To UBound(Split(R, ","))
        T = Split(R, ",")(j): xD1(T) = xD1(T) + 1
Next j: Next R
For Each ky In xD
If Not xD1.exists(ky) Then: ReDim Preserve Ar(n): Ar(n) = ky: n = n + 1
Next
For Each ky In xD1
If Not xD.exists(ky) Then: ReDim Preserve Ar1(n1): Ar1(n1) = ky: n1 = n1 + 1
Next

If n1 > 0 Then
    For j = 0 To UBound(Ar1)
        For Each R In xR1
            T = Ar1(j): L = Len(T): xP = 1
            For j1 = 1 To xD1(T)
                pos = InStr(xP, R, T, 0)
                If pos > 0 Then
                    R.Characters(pos, L).Font.ColorIndex = 3
                    xP = pos + 2
                End If
            Next j1
        Next R
    Next j
End If
If n > 0 Then
    For j = 0 To UBound(Ar)
        For Each R In xR
            T = Ar(j): L = Len(T): xP1 = 1
            For j1 = 1 To xD(T)
                pos = InStr(xP1, R, T, 0)
                If pos > 0 Then
                    R.Characters(pos, L).Font.ColorIndex = 3
                    xP1 = pos + 2
                End If
            Next j1
        Next R
    Next j
End If
End Sub
作者: free72921    時間: 2021-8-30 23:02

回復 11# samwang


    感謝前輩，測試結果運行完美。

小弟自作聰明把彈跳視窗的提示修了一下【請選擇Range A】【請選擇Range B】，這樣比較有示意2個不同範圍的感覺，

非常感謝您與各位前輩的協助。



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)