[已解决]关于字典提取数据的问题

roserice

网上的一个字典和类模块结合读取数据的例子,想把例子中的a1 b1,c1  ,a2 b2 c2去掉,用 a b c 代替,循环读取源数据,但是做了之后只能读取每个主键的第一行数据,求高手帮忙改一下程序,谢谢了

最佳答案

月排行榜 / 总排行榜

psxk3535028-1

2022-4-30 16:01

按你的方法

Public Sub 字典一对多()

Dim dic As Object, i&, j&
    ar = Range("a2:e12") ' & Cells(Rows.Count, 3).End(4).Row)

    Set dic = CreateObject("Scripting.Dictionary")
    Set itemw = New 类1
   'MsgBox ar(2, 1)

    For i = 1 To UBound(ar)
     If ar(i, 1) <> "" Then

      itemw.k = ar(i, 1)

        With itemw
            For d = 1 To 3
                .a = ar(d, 3) ': .a1 = ar(i, 4): .a2 = ar(i, 5)
                .b = ar(d, 4)  ': .b1 = ar(i + 1, 4): .b2 = ar(i + 1, 5)
                .c = ar(d, 5)  ': .c1 = ar(i + 2, 4): .c2 = ar(i + 2, 5)
                 dic.Add itemw.k, itemw
                 br = dic.items

Sheet1.Cells(i + 12, 1) = br(0).k
Sheet1.Cells(d - 1 + i + 12, 3) = br(0).a
Sheet1.Cells(d - 1 + i + 12, 4) = br(0).b
Sheet1.Cells(d - 1 + i + 12, 5) = br(0).c
dic.RemoveAll
    Next
End With
   End If
       Next
   End Sub
你试试，这只能是一种方法，如果单纯读取数据处理，用数组不更好吗，速度也更快

跳转到最佳答案楼层

psxk3535028-1

If ar(i, 1) <> "" Then  就决定了只有A列非空时才会处理后面的数据，另外这里用类模块没有什么意义，都是声明数据类型，反而使代码变得很繁琐

roserice

psxk3535028-1 发表于 2022-4-29 23:57
If ar(i, 1)  "" Then  就决定了只有A列非空时才会处理后面的数据，另外这里用类模块没有什么意义，都是声 ...

类模块在这里确实有些鸡肋，第一列数据是判断标准，是必须的，抛开缺点，如果能完善一下代码，请赐教，

psxk3535028-1

roserice 发表于 2022-4-30 01:27
类模块在这里确实有些鸡肋，第一列数据是判断标准，是必须的，抛开缺点，如果能完善一下代码，请赐教，

没有注意你注释掉的那些代码，那些代码就是扩展到i行的下一行和下下行和列，注释掉就获得不到数据了，你的代码只是获取i行的几列数据，没有向下获取，如果单纯用a，b，c估计要加一个循环了或者用  Offset 来解决，不过感觉都好麻烦，看代码是每个数据都读取一遍，不知道具体什么要求，不敢妄断

roserice

psxk3535028-1 发表于 2022-4-30 09:43
没有注意你注释掉的那些代码，那些代码就是扩展到i行的下一行和下下行和列，注释掉就获得不到数据了，你 ...

要是用原来的代码就什么数据也不能获得了，还不如我这个

roserice

psxk3535028-1 发表于 2022-4-30 09:43
没有注意你注释掉的那些代码，那些代码就是扩展到i行的下一行和下下行和列，注释掉就获得不到数据了，你 ...

看看效果

psxk3535028-1

按你的方法

Public Sub 字典一对多()

Dim dic As Object, i&, j&
    ar = Range("a2:e12") ' & Cells(Rows.Count, 3).End(4).Row)

    Set dic = CreateObject("Scripting.Dictionary")
    Set itemw = New 类1
   'MsgBox ar(2, 1)

    For i = 1 To UBound(ar)
     If ar(i, 1) <> "" Then

      itemw.k = ar(i, 1)

        With itemw
            For d = 1 To 3
                .a = ar(d, 3) ': .a1 = ar(i, 4): .a2 = ar(i, 5)
                .b = ar(d, 4)  ': .b1 = ar(i + 1, 4): .b2 = ar(i + 1, 5)
                .c = ar(d, 5)  ': .c1 = ar(i + 2, 4): .c2 = ar(i + 2, 5)
                 dic.Add itemw.k, itemw
                 br = dic.items

Sheet1.Cells(i + 12, 1) = br(0).k
Sheet1.Cells(d - 1 + i + 12, 3) = br(0).a
Sheet1.Cells(d - 1 + i + 12, 4) = br(0).b
Sheet1.Cells(d - 1 + i + 12, 5) = br(0).c
dic.RemoveAll
    Next
End With
   End If
       Next
   End Sub
你试试，这只能是一种方法，如果单纯读取数据处理，用数组不更好吗，速度也更快

roserice

psxk3535028-1 发表于 2022-4-30 16:01
按你的方法

Public Sub 字典一对多()

谢谢您的启发,按您 的思路,用数组,终于有了结果,把源数据修了一下,第一行删除,第二列删除,
Public br
Public Sub 字典一对多()
Dim cr
Dim dic As Object, i&, j&
    ar = Range("a1:e10") ' & Cells(Rows.Count, 3).End(4).Row)

    Set dic = CreateObject("Scripting.Dictionary")
    Set itemw = New 类1


    For i = 1 To UBound(ar)
     If ar(i, 1) <> "" Then
     cr = Cells(i, 1).CurrentRegion
   itemw.k = ar(i, 1)
      w = 1
      dic.Add itemw.k, itemw
       br = dic.items
      Sheet1.Cells(i + w + 12, 1) = ar(i, 1)
        For d = 1 To 3
       With itemw
        .a = cr(d, 2)
        .b = cr(d, 3)
        .c = cr(d, 4)

Sheet1.Cells(i + w + 12, 2) = br(0).a
Sheet1.Cells(i + w + 12, 3) = br(0).b
Sheet1.Cells(i + w + 12, 4) = br(0).c
  End With
w = w + 1
Next
'Erase cr
End If           
   Next
   End Sub