关于创建新数据表，数据字典

cunfu2010

Sub test()
    Sheet2.UsedRange.Offset(1).ClearContents
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    x = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    arr = Sheet1.Range("A2:C" & x)
    ReDim brr(1 To UBound(arr), 1 To 3)
        For i = 1 To UBound(arr)
            If Not d.exists(arr(i, 1) & "," & arr(i, 3)) Then
               d(arr(i, 1) & "," & arr(i, 3)) = arr(i, 2)
            Else
               d(arr(i, 1) & "," & arr(i, 3)) = d(arr(i, 1) & "," & arr(i, 3)) & "," & arr(i, 2)
            End If
        Next
    For j = 0 To d.Count - 1
        For k = 1 To 2
        brr(j, k) = Split(d.keys()(j), ",")(k - 1)
        Next
        brr(j, 3) = d.items()(j)
    Next
    Sheet2.[D2].Resize(UBound(arr), 3) = brr
    Application.ScreenUpdating = True
End Sub

everbest2015

详情请见附件

everbest2015

控件按钮在H列

无穷大

abc123281 发表于 2019-1-18 22:36
Private Sub CommandButton1_Click()
Dim arr, brr(1 To 1000, 1 To 3)
Set d = CreateObject("scripting ...

Name79    67240254
对应的结果:SO2018120300051,SO2018120600045,SO2018122400013,SO2018121000088,SO2018121400084,SO2018122100085,SO2018121200078,SO2018120700001,SO2018122000009,SO2019010300014,SO2018121200095,SO2018120300051,SO2018122400012,SO2018120300051,SO2018122400012

还是有点问题，如上所示：红色的数据，在结果中，有重复值

无穷大

everbest2015 发表于 2019-1-18 22:56
控件按钮在H列

感谢协助，还是有点问题,E列值为：67240254 所对应的F列值：SO2018120300051,SO2018120600045,SO2018122400013,SO2018121000088,SO2018121400084,SO2018122100085,SO2018121200078,SO2018120700001,SO2018122000009,SO2019010300014,SO2018121200095,SO2018120300051,SO2018122400012,SO2018120300051,SO2018122400012
有重复，这个地方如何处理呢

无穷大

统一回复，不会高级办法，又多用了一次数据字典，搞定了我想要的结果，感谢各位，新年快乐

everbest2015

请问四楼大师,为什么我的代码最后rept出来的  总有一些是错误值呢,感觉很纳闷啊,找不到原因,望明示,感谢

cjc209

Sub 字典汇总()
    Dim arr, brr
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion '数据装入数组
    For i = 1 To UBound(arr)
         tjz = arr(i, 1) & arr(i, 3) '条件
            If d.Exists(tjz) Then '字典里存在的时候
                brr = d(tjz) '字典关键字对应的条目的值装入结果数组（可以为数组）
                brr(3) = brr(3) & "," & arr(i, 2) '要汇总的列
            Else
                ReDim brr(1 To UBound(arr, 2)) '声明动态数组 装符合条件的每列数据
               
                    brr(1) = arr(i, 1) '需要的字段装入结果数组
                    brr(2) = arr(i, 3)
                    brr(3) = arr(i, 2)
            End If
            d(tjz) = brr '更新字典条目中的值
    Next
    If d.Count Then
        Sheet2.Range("a1").CurrentRegion.ClearContents '清除结果区的数据
        brr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.Items)) '数组装置
        Sheet2.Range("a1").Resize(d.Count, UBound(brr, 2)) = brr '赋值
    End If
End Sub

abc123281

everbest2015 同学你好
    错误的原因  是字典的条目中字符超过256转置就会失败  导致出现错误值  后续转置给数组就行  
已做了修改  请测试附件  

reaa123.rar (29.01 KB, 下载次数: 3)

2019-1-19 11:51 上传

点击文件名下载附件

duquancai

无穷大 发表于 2019-1-18 23:14
Name79    67240254
对应的结果:SO2018120300051,SO2018120600045,SO2018122400013,SO2018121000088,SO ...

1. # -*- coding: utf-8 -*-
   
2. # version: Python 3.7.0
   
3. import pandas as pd
   
4. from collections import defaultdict
   
5. #读取Excel文件中的数据，注意文件路径、文件名及表名！
   
6. data = pd.read_excel(r'D:\python\project\aa.xlsm', sheet_name='Sheet1')
   
7. my_dic = defaultdict(set)
   
8. for i in data.values:
   
9.     my_dic[str(i[0]) + ',' + str(i[2])] |= {str(i[1])}
   
10. my_list = [[k.split(',')[0], k.split(',')[1], ','.join(list(v))] for k, v in my_dic.items()]
    
11. #数据写入Excel文件，注意文件路径！
    
12. df = pd.DataFrame(my_list, columns=["Name", "No", "NewOrder"])
    
13. with pd.ExcelWriter(r'D:\python\project\输出结果.xlsx') as writer:
    
14.     df.to_excel(writer, 'Sheet1', index=False, header=True)

复制代码