字典查重并保存数据！万分感谢！

yjgy6669

求教老师，帮忙一下！万分感谢！

这个是VBA代码，真心想学！买了书还看不懂，先谢谢老师了！
附件已上了！再次感谢！

ben168

tel3033

1. Private Sub CommandButton1_Click()
   
2.     Dim i%, j%, endRow%, dwNum%, s$, arr, brr(), d As Object
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheet2.[c2].CurrentRegion: dwNum = UBound(arr)
   
5.     For i = 2 To UBound(arr)
   
6.         s = arr(i, 11): d(s) = ""
   
7.     Next
   
8.     arr = Sheet1.[c2].CurrentRegion
   
9.     For i = 2 To UBound(arr)
   
10.         If arr(i, 12) <> "" Then
    
11.             s = arr(i, 12)
    
12.             If Not d.exists(s) Then
    
13.                 d(s) = i: endRow = endRow + 1
    
14.                 ReDim Preserve brr(1 To 13, 1 To endRow)
    
15.                 For j = 1 To 13
    
16.                     brr(j, endRow) = arr(d(s), j + 1)
    
17.                     brr(11, endRow) = "'" & arr(d(s), 12)
    
18.                 Next
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     With Sheet2
    
23.         i = UBound(brr, 2)
    
24.         .Rows("2:" & i + 1).Insert Shift:=xlDown
    
25.         .Rows("2:" & i + 1).RowHeight = 13.5
    
26.         .Rows("2:" & i + 1).Font.Bold = False
    
27.         .Range("c2").Resize(i, UBound(brr)) = Application.Transpose(brr)
    
28.         i = .Cells(Rows.Count, "m").End(xlUp).Row - 1
    
29.     End With
    
30.     MsgBox "共计" & i & "人", , "提示"
    
31. End Sub

复制代码

gwjkkkkk

代码审核中，请稍候下载。。。
请楼主参考。。。

yjgy6669

gwjkkkkk 发表于 2022-5-16 19:58
代码审核中，请稍候下载。。。
请楼主参考。。。

太棒了！是我想要的效果，就是还有一个问题还请帮忙，就是怎么忽略M列空白单元格呢？
因为我看了一下，有把空置的也直接保存进去了

gwjkkkkk

yjgy6669 发表于 2022-5-17 09:58
太棒了！是我想要的效果，就是还有一个问题还请帮忙，就是怎么忽略M列空白单元格呢？
因为我看了一下， ...

请楼主参考。。。

yjgy6669

gwjkkkkk 发表于 2022-5-17 10:23
请楼主参考。。。

感谢~~~~！

yjgy6669

ben168 发表于 2022-5-16 19:09

你好！能不能发个可以复制的哈？或者文件也行，万分感谢！

ben168

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False                         '关闭屏幕更新
    Dim d As Object, arr, brr, i, count1
    Set d = CreateObject("scripting.dictionary")               '建立字典
    arr = Sheets("数据库").Range("M1:M" & Sheets("数据库").[m65535].End(xlUp).Row)
    brr = Sheets("有效").Range("M1:M" & Sheets("有效").[m65535].End(xlUp).Row)
    count1 = 0
    For i = 1 To UBound(arr)                                   '装入字典
        d(arr(i, 1)) = ""
    Next i
    For i = 3 To UBound(brr)
        If brr(i, 1) <> "" Then
            If Not d.exists(brr(i, 1)) Then
                count1 = count1 + 1
                Sheets("数据库").Range("C2:O2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove    '下移原有数据
                Sheets("有效").Range("C" & i & ":O" & i).Copy Sheets("数据库").Range("C2")    '复制新人员信息
            End If
        End If
    Next i
    Set arr = Nothing
    Set brr = Nothing
    Set d = Nothing
    MsgBox "共计  " & count1
    Application.ScreenUpdating = True
End Sub

sdytsxd991122