A、B、C三列字符串对比，如何实现

grf1973

25楼的最简洁高效。改一下就对了。

1. Sub test()
   
2.     ar = [a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For j = 1 To 4 '循环列数并标识字典
   
5.         For i = 2 To UBound(ar)
   
6.             s = Mid(ar(i, j), 1, 6) '取前六位字
   
7.             If j = 1 Then
   
8.                 d(s) = 1
   
9.             Else
   
10.                 If d(s) = j - 1 Then d(s) = j
    
11.             End If
    
12.         Next
    
13.     Next
    
14.     ReDim br(1 To d.Count, 1 To 1)
    
15.     For Each s In d.keys '查找有4列标识的关键字
    
16.         If d(s) = 4 Then
    
17.             n = n + 1
    
18.             br(n, 1) = s
    
19.         End If
    
20.     Next
    
21.     [f2].Resize(n, 1) = br
    
22. End Sub

复制代码

DevilW

grf1973 发表于 2021-9-18 16:19
25楼的最简洁高效。改一下就对了。

你不说我还没发现错误，我把有4列标识的给去除了

APPLE123

AmoKat 发表于 2021-9-18 12:58
#27樓程式中 LC=6 改為 LC=99就可以

谢谢老师帮助

APPLE123

准提部林 发表于 2021-9-18 12:24
Sub TEST_A1()
Dim Arr, R&, xD, T$, U$, i&, j%, N&
Set xD = CreateObject("Scripting.Dictionary")

请教老师，这个代码好像是针对4列的
如果A、B、C三列字符串对比，如果3列中分别都有一个单元格的内容相同，就将相同的内容提取出来，放到F列
请问，该如何修改您的代码？
麻烦老师帮忙指点，谢谢！

准提部林

APPLE123 发表于 2021-9-18 20:49
请教老师，这个代码好像是针对4列的
如果A、B、C三列字符串对比，如果3列中分别都有一个单元格的内容相 ...

Sub TEST_A2()
Dim Arr, R&, C%, xD, T$, U$, i&, j%, N&
Set xD = CreateObject("Scripting.Dictionary")
[f2:f6000].ClearContents
C = 3 '列
For j = 1 To C
    R = Cells(Rows.Count, j).End(3).Row
    Arr = Cells(1, j).Resize(R + 1)
    For i = 2 To R
        T = Arr(i, 1): U = xD(T) & String(C, " ")
        Mid(U, j, 1) = 1:  U = Trim(U)
        If U = String(C, "1") Then N = N + 1: Arr(N, 1) = T: U = ""
        xD(T) = U
    Next i
Next j
If N > 0 Then [f2].Resize(N) = Arr
End Sub

准提部林

APPLE123 发表于 2021-9-18 20:49
请教老师，这个代码好像是针对4列的
如果A、B、C三列字符串对比，如果3列中分别都有一个单元格的内容相 ...

用31樓代碼改下:
Sub TEST_A1()
Dim Arr, R&, C%, xD, T$, U%, i&, j%, N&
Set xD = CreateObject("Scripting.Dictionary")
[f2:f6000].ClearContents
C = 3 '列
For j = 1 To C
    R = Cells(Rows.Count, j).End(3).Row
    Arr = Cells(1, j).Resize(R + 1)
    For i = 2 To R
        T = Arr(i, 1): U = xD(T)
        If U = j - 1 Then U = j
        If U = C Then N = N + 1: Arr(N, 1) = T: U = 9
        xD(T) = U
i01: Next i
Next j
If N > 0 Then [f2].Resize(N) = Arr
End Sub

APPLE123

准提部林 发表于 2021-9-19 10:53
用31樓代碼改下:
Sub TEST_A1()
Dim Arr, R&, C%, xD, T$, U%, i&, j%, N&

谢谢老师！
请教老师：
1、原来你的代码中定义U$，现在定义U%，后面均有U = xD(T)...... xD(T) = U
可以解释一下U = xD(T) 、xD(T) = U的意思吗？
2、当前代码中 U = 9是什么意思？或者说为何等于9 ？
麻烦老师抽空解析，谢谢！

APPLE123

准提部林 发表于 2021-9-19 10:52
Sub TEST_A2()
Dim Arr, R&, C%, xD, T$, U$, i&, j%, N&
Set xD = CreateObject("Scripting.Dictionar ...

谢谢老师！
可否解释一下这几句
For i = 2 To R
        T = Arr(i, 1): U = xD(T) & String(C, " ")
        Mid(U, j, 1) = 1:  U = Trim(U)
        If U = String(C, "1") Then N = N + 1: Arr(N, 1) = T: U = ""
        xD(T) = U
谢谢！

准提部林

APPLE123 发表于 2021-9-19 12:36
谢谢老师！
请教老师：
1、原来你的代码中定义U$，现在定义U%，后面均有U = xD(T)...... xD(T) = U

35樓是以"文本" 為判斷, 故設U$ 即 U As String
String(C, "1") ...是依C的數字, 產生連續的"1"文本,例: C=2, 為"11", C=3, 為"111"...類推
若三列都有, 肯定 U 必為"111", 依此即符合條件
===================================
36樓是以"數值" 為判斷, 故設U% 即 U As As Single
U 是隨 j 而變動, 當U=C (亦即 U=3) 時, 符合條件取出文本, 再將 U 設成 9, 放回字典!!!
U = 9, 這個 9 是隨便給的, 也可以 99, 或 555, 或任意數字, 只要 U 大于 C值 即可

APPLE123

准提部林 发表于 2021-9-19 14:52
35樓是以"文本" 為判斷, 故設U$ 即 U As String
String(C, "1") ...是依C的數字, 產生連續的"1"文本,例: ...

谢谢老师指点，回去慢慢消化