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

wwdfefgg

AmoKat 发表于 2021-9-16 23:37
Sub test4AmoKat()
    Dim d, i, j, Arr, K$, x
    Set d = CreateObject("Scripting.Dictionary") '字 ...

谢谢。。。。。。。。。

笨鸟飞不高

test.zip (58.24 KB, 下载次数: 6)

2021-9-17 16:49 上传

点击文件名下载附件

lsdongjh

wwdfefgg 发表于 2021-9-16 22:55
麻烦再看看，，我回复了，，现在变成4列如何弄？？

看懂我的代码，只需要加 2句：

wwdfefgg

多谢各位大师

DevilW

1. Sub test()
   
2.     ar = [a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dicctionary")
   
4.     For j = 1 To 4 '循环列数并标识字典
   
5.         For i = 2 To UBound(ar)
   
6.             s = Mid(ar(i, 1), 1, 6) '取前六位字符
   
7.             If j = 1 Then
   
8.                 d(s) = j '第一列打基础
   
9.             Else
   
10.                 '关键字已有前一列则标识为本列标识
    
11.                 If d(s) = j - 1 Then d(s) = j
    
12.             End If
    
13.         Next
    
14.     Next
    
15.     For i = d.Count - 1 To 0 Step -1 '剔除没有4列标识的关键字
    
16.         If d(d.keys()(i)) <> 4 Then d.Remove (d.keys()(i))
    
17.     Next
    
18.     '转置关键字并写入单元格
    
19.     [f2].Resize(d.Count, 1) = Application.Transpose(d.keys())
    
20. End Sub

复制代码

APPLE123

AmoKat 发表于 2021-9-16 21:33
Sub test4AmoKat()
    Dim d, i, j, Arr, K$, x
    Set d = CreateObject("Scripting.Dictionary") '字 ...

请教老师:本例中，如果将条件“3列中分别都有一个单元格的前6个字母相同”改为“3列中分别都有一个单元格相同”，其他条件不变，该如何修改代码？
我删除有关left，提示，remove那一行出错
麻烦老师帮忙指点，谢谢！

AmoKat

APPLE123 发表于 2021-9-18 08:38
请教老师:本例中，如果将条件“3列中分别都有一个单元格的前6个字母相同”改为“3列中分别都有一个单元格 ...

不是很清楚你的需求，將取6字元改為 LC 變數，輸入99取全部
items 原來是 Key & 檢查序號，改為 檢查序號 & Key

Sub test4AmoKat()
    Dim d, i, j, Arr, K$, x, LC
    Set d = CreateObject("Scripting.Dictionary") '字典
    Arr = [a1].CurrentRegion 'Arr = A1:D1963
    c = UBound(Arr, 2)
    LC = 6 '控制為Key的長度，例如6為取前6字為KEY，99為取全部自原為KEY
    For i = 1 To c
        For j = 2 To UBound(Arr)
            If Len(Arr(j, i)) > 6 Then
                K = Left(Arr(j, i), LC) '前LC個字元為Key
                N = Left(d(K) & "         ", 9): Mid(N, i, 1) = i
                d(K) = N & K '前面標註123為ABC欄都有
            End If
        Next
    Next
   
    'debug use
    Cells(1, c + 3).Resize(65536, 1).ClearContents
    Cells(1, c + 3).Resize(d.Count, 1) = Application.Transpose(d.items)
   
    '刪除不完整資料
    For Each x In d.items
        If Left(x, c) <> Left("123456789", c) Then d.Remove Mid(x, 10, 99)
    Next
    Cells(1, c + 2).Resize(65536, 1).ClearContents
    If d.Count > 0 Then _
    Cells(1, c + 2).Resize(d.Count, 1) = Application.Transpose(d.keys)
    Set d = Nothing
End Sub

APPLE123

AmoKat 发表于 2021-9-18 11:43
不是很清楚你的需求，將取6字元改為 LC 變數，輸入99取全部
items 原來是 Key & 檢查序號，改為 檢查序 ...

谢谢老师！
可能是我没说清楚，不好意思
我的意思是:整个单元格的内容进行比较，三列中都有相同的单元格内容，就提取出来。
不是单元格的前6个字符进行比较
可否请老师再帮忙看看该如何修改？
谢谢！

准提部林

Sub TEST_A1()
Dim Arr, R&, xD, T$, U$, i&, j%, N&
Set xD = CreateObject("Scripting.Dictionary")
For j = 1 To 4
    R = Cells(Rows.Count, j).End(3).Row
    Arr = Cells(1, j).Resize(R + 1)
    For i = 2 To R
        T = Left(Arr(i, 1), 6): If T = "" Then GoTo i01
        U = xD(T): If U = "" Then U = "SSS"
        If j = 4 Then
           If U = "111" Then N = N + 1: Arr(N, 1) = T
           xD(T) = "": GoTo i01
        End If
        Mid(U, j, 1) = 1: xD(T) = U
i01: Next i
Next j
If N > 0 Then [f2].Resize(N) = Arr
End Sub

若文本完整比對
T = Left(Arr(i, 1), 6) 改成 T = Arr(i, 1)

AmoKat

APPLE123 发表于 2021-9-18 12:22
谢谢老师！
可能是我没说清楚，不好意思
我的意思是:整个单元格的内容进行比较，三列中都有相同的单元 ...

#27樓程式中 LC=6 改為 LC=99就可以