求助，vba数据字典。提示下标越界。

squallzhe

求助，vba数据字典。提示下标越界。

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

zhaojiaoyang200

对象变量赋值要用Set ,试试：
Set wb  ...............

这个是昵称吗

我也不懂你看是不是这样
arr = wb.Sheets(4).Range("A2:P" & wb.Sheets(4).Cells(Rows.Count, 1).End(xlUp).Row)

squallzhe

zhaojiaoyang200 发表于 2018-4-23 11:17
对象变量赋值要用Set ,试试：
Set wb  ...............

还是提示下标越界。-_-

Sub 提取多字段不重复数据()
    Dim i&, j%, k&, arr, brr, crr
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    Dim wb As Workbook
    'filepath = "F:\数据管理与运营支持\基础数据\业务数据\安邦人寿-银保-2018.1.1-4.11.xlsm"
    'wb = ThisWorkbook.Path & "\安邦人寿-银保-2018.1.1-4.11.xlsm"
    Set wb = GetObject("F:\数据管理与运营支持\基础数据\业务数据\安邦人寿-银保-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

abc123281

想要得到答案  最好上传附件

squallzhe

附件，请参考。要实现，在附件2中写入程序，将附件1中的第1、第4和第7列，不完全重复的字段，生成在附件2的sheet3中。谢谢。

squallzhe

abc123281 发表于 2018-4-23 12:02
想要得到答案  最好上传附件

已在6楼，上传附件。

gdw831001

arr = wb.Sheets(1).Range("A2:P" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)

squallzhe

gdw831001 发表于 2018-4-23 12:41
arr = wb.Sheets(1).Range("A2:P" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)

非常感谢！