调试了一下。现在变成提示:“下标越界”。
Sub 提取多字段不重复数据()
Dim i&, j%, k&, arr, brr, crr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim wb
wb = ThisWorkbook.Path & "\安邦人寿-银保-2018.1.1-4.11.xlsm"
arr = wb.Sheets(4).Range("A2:P" & Sheets(4).Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To UBound(arr)
'If arr(i, 5) <> "" Then(可加入条件)
d(arr(i, 1) & "-" & arr(i, 4) & "-" & arr(i, 7)) = ""
Next
brr = Application.Transpose(d.keys)
ReDim crr(1 To UBound(brr), 1 To 3)
For k = 1 To d.Count
crr(k, 1) = Split(brr(k, 1), "-")(0)
crr(k, 2) = Split(brr(k, 1), "-")(1)
crr(k, 3) = Split(brr(k, 1), "-")(2)
Next
Sheet3.Range("A2").Resize(UBound(crr), 3) = crr
End Sub
|