求合并表格，按照条件顺序去重复代码

540872759

请求大神帮忙写个VBA，逻辑如下
1.将附件 1 2 3 的excel表格自动合并成一份完整的表格
2.按照K列 钻>金>银>铜 的条件顺序删除A类的重复号码，如 K列的钻与金有重复的号码，保留钻的号码，删除金的重复号码
当钻与铜有重复号码时，保留钻的号码，删除铜的号码，当银与铜重复号码时，删除铜保留银，最后都A列无重复单号

dsmch

1. Sub dsmch()
   
2. Dim arr, brr, d, w, i&, s&, j%
   
3. w = Array("钻", "金", "银", "铜")
   
4. Set d = CreateObject("scripting.dictionary")
   
5. ReDim brr(1 To 20000, 1 To 12)
   
6. Range("a2:l20000").ClearContents
   
7. mypath = ThisWorkbook.Path & ""
   
8. wj = Dir(mypath & "*.xls*")
   
9. Do While wj <> ""
   
10.     If wj <> ThisWorkbook.Name Then
    
11.         With GetObject(mypath & wj)
    
12.             arr = .Sheets(1).Range("a1").CurrentRegion
    
13.             .Close 0
    
14.         End With
    
15.         For i = 2 To UBound(arr)
    
16.             If Not d.exists(arr(i, 11)) Then
    
17.                 d(arr(i, 11)) = ""
    
18.                 Set d(arr(i, 11)) = CreateObject("scripting.dictionary")
    
19.             End If
    
20.             If Not d(arr(i, 11)).exists(arr(i, 1)) Then d(arr(i, 11))(arr(i, 1)) = i
    
21.         Next
    
22.         For i = 0 To UBound(w)
    
23.             For Each b In d(w(i)).items
    
24.                 If Not d.exists(arr(b, 1)) Then
    
25.                     d(arr(b, 1)) = ""
    
26.                     s = s + 1
    
27.                     For j = 1 To UBound(arr, 2)
    
28.                         brr(s, j) = arr(b, j)
    
29.                     Next
    
30.                 End If
    
31.             Next
    
32.         Next
    
33.     End If
    
34.     wj = Dir
    
35. Loop
    
36. Range("a2").Resize(s, UBound(brr, 2)) = brr
    
37. End Sub

复制代码

dsmch

………………

dsmch

论坛缺陷，第7句代码“\”缺失
mypath = ThisWorkbook.Path & "\"

540872759

dsmch 发表于 2019-1-13 06:11
论坛缺陷，第7句代码“\”缺失
mypath = ThisWorkbook.Path & "\"

大神，可不可以A列是一开始就是保转化为文本格式去重复的，因为号码第一位数字有可能是0，然后按条件合并去重之后，如果钻与钻之间还存在重复的号码也是要去重复的

540872759

540872759 发表于 2019-1-13 22:24
大神，可不可以A列是一开始就是保转化为文本格式去重复的，因为号码第一位数字有可能是0，然后按条件合并 ...

如图片般，A列号码为文本格式，且K列相同条件也无重复值

dsmch

540872759 发表于 2019-1-13 22:24
大神，可不可以A列是一开始就是保转化为文本格式去重复的，因为号码第一位数字有可能是0，然后按条件合并 ...

上传附件模拟一下结果

540872759

dsmch 发表于 2019-1-14 05:41
上传附件模拟一下结果

请查看压缩包中的图片，结果就如图片所示

dsmch

For i = 2 To UBound(arr)
            arr(i, 1) = "'" & arr(i, 1)
            If Not d.exists(arr(i, 11)) Then
                d(arr(i, 11)) = ""

540872759

dsmch 发表于 2019-1-14 22:15
For i = 2 To UBound(arr)
            arr(i, 1) = "'" & arr(i, 1)
            If Not d.exists(arr( ...

Sub dsmch()
Dim arr, brr, d, w, i&, s&, j%
w = Array("钻", "金", "银", "铜")
Set d = CreateObject("scripting.dictionary")
ReDim brr(1 To 20000, 1 To 12)
Range("a2:l20000").ClearContents
mypath = ThisWorkbook.Path & "\"
wj = Dir(mypath & "*.xls*")
Do While wj <> ""
    If wj <> ThisWorkbook.Name Then
        With GetObject(mypath & wj)
            arr = .Sheets(1).Range("a1").CurrentRegion
            .Close 0
        End With
        For i = 2 To UBound(arr)
        arr(i, 1) = "'" & arr(i, 1)
            If Not d.exists(arr(i, 11)) Then
                d(arr(i, 11)) = ""
                Set d(arr(i, 11)) = CreateObject("scripting.dictionary")
            End If
            If Not d(arr(i, 11)).exists(arr(i, 1)) Then d(arr(i, 11))(arr(i, 1)) = i
        Next
        For i = 0 To UBound(w)
            For Each b In d(w(i)).items
                If Not d.exists(arr(b, 1)) Then
                    d(arr(b, 1)) = ""
                    s = s + 1
                    For j = 1 To UBound(arr, 2)
                        brr(s, j) = arr(b, j)
                    Next
                End If
            Next
        Next
    End If
    wj = Dir
Loop
Range("a2").Resize(s, UBound(brr, 2)) = brr
End Sub



放入了以上的代码，然后文档里面有7个excel文档，运行代码是出现“运行时错误9 下标越界 ” 的提示，请问是缺了什么吗