- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-10-30
|
本帖最後由 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 |
|
發表於 2021-8-30 14:28
| 
