二列数据找相同项数组法

cysczhumh

loirol 发表于 2025-1-26 11:35

谢谢，非常正确。去掉k=0也可以有正确的结果。明白了Preserve 的意思。

loirol

cysczhumh 发表于 2025-1-26 11:54
谢谢，非常正确。去掉k=0也可以有正确的结果。明白了Preserve 的意思。

你要令k初始等于1的话，就应该写完crr再k=k+1，不然crr的第一行是空的

cysczhumh

3190496160 发表于 2025-1-26 11:38

谢谢！非常正确。数组的表示方法很有学问呀！

西瓜籽

按你的思路修改了一下，供参考

cysczhumh

西瓜籽 发表于 2025-1-26 14:15
按你的思路修改了一下，供参考

谢谢，非常正确！数组的维数设置用得是出神入化，高手啊！

cysczhumh

3190496160 发表于 2025-1-26 11:38

谢谢，非常正确!先设置A列行数大小的数组，因B列中与A列相同的数的个数是不会超过A列的，就不会出现下界问题，这也是一条很好的思路。

ykcbf1100

这个题，chxw68老师的代码刚好适用。

ykcbf1100

AB列比较

1. Sub test2()    '//AB列比较, 源代码来自chxw68老师
   
2.     Dim tm: tm = Timer
   
3.     Dim arr, brr, m(1 To 3)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Worksheets("sheet1")
   
6.         .[d1].CurrentRegion.Offset(1).ClearContents
   
7.         r = .UsedRange.Rows.Count
   
8.         arr = .Range("a2:b" & r)
   
9.         For j = 1 To UBound(arr, 2)
   
10.             For i = 1 To UBound(arr)
    
11.                 s = arr(i, j)
    
12.                 If s <> Empty Then d(s) = d(s) Or j
    
13.             Next
    
14.         Next
    
15.         ReDim brr(1 To UBound(arr) * 2, 1 To 4)
    
16.         For Each k In d.keys
    
17.             t = d(k)
    
18.             n = n + 1
    
19.             brr(n, 4) = k
    
20.             m(t) = m(t) + 1
    
21.             brr(m(t), t) = k
    
22.         Next
    
23.         .Range("d2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
24.     End With
    
25.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
26. End Sub
    
27. 
    

复制代码

gwjkkkkk

Option Explicit
Sub test1()
    Dim j&, cnn As Object, rst As Object, strSQL$, strFileName$
   
    Application.ScreenUpdating = False
    Set cnn = CreateObject("ADODB.Connection")
   
    strFileName = ThisWorkbook.FullName
    Select Case Application.Version * 1
        Case Is <= 11
            cnn.Open "Provider=Microsoft.JET.OLEDB.4.0;Data Source=" & strFileName & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=0'"
        Case Is >= 12
            cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFileName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=0'"
    End Select
   
    strSQL = "SELECT B FROM [" & Worksheets(1).Name & "$A1:B] WHERE B IN(SELECT A FROM [" & Worksheets(1).Name & "$A1:B] WHERE A IS NOT NULL)"
    Set rst = cnn.Execute(strSQL)
   
    With Worksheets(1)
        With .Range("D1")
            .CurrentRegion.Clear
            .Value = "结果"
            .Offset(1).CopyFromRecordset rst
        End With
        .Activate
    End With
   
    rst.Close: cnn.Close
    Set rst = Nothing: Set cnn = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

字典也比较简单，用SQL写一个，代码审核中。。。