提取证号

ddz79101

老师，这样的表格如何提取号码，请看看

cjc209

=XLOOKUP(B3,sheet1!B:B,sheet1!D:D,,)

ddz79101

cjc209 发表于 2024-12-21 21:35
=XLOOKUP(B3,sheet1!B:B,sheet1!D:D,,)

谢谢老师！能否帮忙用VBA

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
会提取最后面的数据，连其他4列的一起处理了
Sub test()
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    Set sh = wb.Sheets("sheet2")
    arr = sht.[a1].CurrentRegion
    crr = sh.[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        s = arr(i, 2)
        If Not d.exists(s) Then
            d(s) = Array("'" & arr(i, 4), arr(i, 5), arr(i, 6), arr(i, 7), arr(i, 8))
        Else
            brr = d(s)
            d(s) = Array(IIf(arr(i, 4) <> Empty, "'" & arr(i, 4), brr(0)), IIf(arr(i, 5) <> Empty, arr(i, 5), brr(1)), _
                    IIf(arr(i, 6) <> Empty, arr(i, 6), brr(2)), IIf(arr(i, 7) <> Empty, arr(i, 7), brr(3)), _
                    IIf(arr(i, 8) <> Empty, arr(i, 8), brr(4)))
        End If
    Next
    For i = 2 To UBound(crr)
        s = crr(i, 2)
        If d.exists(s) Then
            sh.Cells(i, 4).Resize(, 5) = d(s)
        End If
    Next
    Beep
End Sub

ddz79101

quqiyuan 发表于 2024-12-21 22:14
参与一下，仅供参考。。。

谢谢老师！运行成功

ykcbf1100

字典排重就可以了。

ykcbf1100

经典的字典排重。

1. Sub ykcbf()   '//2024.12.22
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 2).End(3).Row
   
6.         arr = .[a1].Resize(r, 8)
   
7.     End With
   
8.     ReDim brr(1 To 10000, 1 To 100)
   
9.     For i = 3 To UBound(arr)
   
10.         s = arr(i, 2)
    
11.         If Not d.exists(s) Then
    
12.             m = m + 1
    
13.             d(s) = m
    
14.             brr(m, 1) = m
    
15.             For j = 2 To UBound(arr, 2)
    
16.                 brr(m, j) = arr(i, j)
    
17.             Next
    
18.         End If
    
19.     Next
    
20.     With Sheets("Sheet2")
    
21.         .UsedRange.Offset(2).ClearContents
    
22.         .Columns(4).NumberFormatLocal = "@"
    
23.         .[a3].Resize(m, UBound(arr, 2)) = brr
    
24.     End With
    
25.     Set d = Nothing
    
26.     Application.ScreenUpdating = False
    
27.     MsgBox "OK！"
    
28. End Sub
    

复制代码

z865593849

去重

cjc209

cjc209 发表于 2024-12-21 21:35
=XLOOKUP(B3,sheet1!B:B,sheet1!D:D,,)

vba 就用字典法