[已解决]工程明细数

wucj80

老师们，谢谢了，sheet2是我想要的表

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-18 16:31

1. Option Explicit
   
2. 
   
3. Sub 合并数据()
   
4.     Dim data
   
5.     '读源数据
   
6.     With Worksheets("Sheet1")
   
7.         data = .Range("a1").CurrentRegion
   
8.     End With
   
9. 
   
10.     '字典，装数据和列类别
    
11.     Dim dic As Object, dicItem As Object
    
12.     Set dic = CreateObject("scripting.dictionary")
    
13.     Set dicItem = CreateObject("scripting.dictionary")
    
14. 
    
15.     Dim arr1
    
16.     arr1 = Array("餐费", "早餐", " 午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", _
    
17.     "车费", "住宿费", "修理费", "工具费", "招待费", "水电", "项目检查费", "人情费", "合计", "联系人姓名", "联系人电话", "备注")
    
18.    
    
19.     '定义列坐标
    
20.     Dim t, i&
    
21.     For Each t In arr1
    
22.         i = i + 1
    
23.         dicItem(t) = i
    
24.     Next
    
25.     '以A|B列数据为KEY
    
26.     Dim StrKey$
    
27.     Dim Result(), iPos&
    
28.     For i = LBound(data) + 1 To UBound(data)    '第一行为标题
    
29.         StrKey = data(i, 1) & "|" & data(i, 2)
    
30.         If Not dic.exists(StrKey) Then      '检测字典中是否存在Strkey
    
31.             ReDim Result(1 To dicItem.Count)
    
32.             iPos = dicItem(data(i, 3))      '取列坐标
    
33.             Result(iPos) = data(i, 4)       '写入数据
    
34.             'If iPos > 1 And iPos < 6 Then Result(1) = data(i, 4)
    
35.             Result(dicItem.Count) = data(i, 5)  '备注
    
36.             dic(StrKey) = Result                '写入字典
    
37.         Else
    
38.             Result = dic(StrKey)                '取数组
    
39.             iPos = dicItem(data(i, 3))          '坐标
    
40.             Result(iPos) = Result(iPos) + data(i, 4)    '累加
    
41.             'If iPos > 1 And iPos < 6 Then Result(1) = Result(1) + data(i, 4)
    
42.             Result(dicItem.Count) = data(i, 5)  '备注
    
43.             dic(StrKey) = Result                '写回字典
    
44.         End If
    
45.     Next
    
46.    
    
47.     '结果数据写入Sheet3
    
48.     With Worksheets("Sheet3")
    
49.         i = .Cells(Rows.Count, 1).End(xlUp).Row '取最后一行数据位置
    
50.         If i > 3 Then .Range("a4:aa" & i).ClearContents '4为第一行数据位置
    
51.         Result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))    '数据经过2次转置变成2维数组
    
52.         .Range("h4").Resize(UBound(Result), UBound(Result, 2)) = Result                 '写入到H4
    
53.         
    
54.         '把KEY转变成一维数组，存入对应的ITEM
    
55.         For Each t In dic.keys
    
56.             dic(t) = Split(t, "|")
    
57.         Next
    
58.         
    
59.         'Items经过2次转换变成2维数组
    
60.         Result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
    
61.         .Range("a4").Resize(UBound(Result), UBound(Result, 2)) = Result '写入A4
    
62.         i = .Cells(Rows.Count, 1).End(xlUp).Row
    
63.         '添加边框
    
64.         With .Range("a4:aa" & i).Borders
    
65.             .LineStyle = xlContinuous
    
66.         End With
    
67.     End With
    
68. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 合并数据()
   
2.     Dim data
   
3.     With Worksheets("Sheet1")
   
4.         data = .Range("a1").CurrentRegion
   
5.     End With
   
6. 
   
7.     Dim dic As Object, dicItem As Object
   
8.     Set dic = CreateObject("scripting.dictionary")
   
9.     Set dicItem = CreateObject("scripting.dictionary")
   
10. 
    
11.     Dim arr1
    
12. 
    
13.     arr1 = Array("餐费", "早餐", " 午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", "车费", "住宿费", "修理费", "工具费", "招待费", "水电", "项目检查费", "人情费", "合计", "联系人姓名", "联系人电话", "备注")
    
14.     Dim t, i&
    
15.     For Each t In arr1
    
16.         i = i + 1
    
17.         dicItem(t) = i
    
18.     Next
    
19.     Dim StrKey$
    
20.     Dim Result(), iPos&
    
21.     For i = LBound(data) + 1 To UBound(data)
    
22.         StrKey = data(i, 1) & "|" & data(i, 2)
    
23.         If Not dic.exists(StrKey) Then
    
24.             ReDim Result(1 To dicItem.Count)
    
25.             iPos = dicItem(data(i, 3))
    
26.             Result(iPos) = data(i, 4)
    
27.             'If iPos > 1 And iPos < 6 Then Result(1) = data(i, 4)
    
28.             Result(dicItem.Count) = data(i, 5)
    
29.             dic(StrKey) = Result
    
30.         Else
    
31.             Result = dic(StrKey)
    
32.             iPos = dicItem(data(i, 3))
    
33.             Result(iPos) = Result(iPos) + data(i, 4)
    
34.             'If iPos > 1 And iPos < 6 Then Result(1) = Result(1) + data(i, 4)
    
35.             Result(dicItem.Count) = data(i, 5)
    
36.             dic(StrKey) = Result
    
37.         End If
    
38.     Next
    
39. 
    
40.     With Worksheets("sheet3")
    
41.         i = .Cells(Rows.Count, 1).End(xlUp).Row
    
42.         If i > 3 Then .Range("a4:aa" & i).ClearContents
    
43.         '.Range("a1").ClearContents
    
44.         '.Range("c1").Resize(, UBound(arr1) + 1) = arr1
    
45.         Result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
    
46.         .Range("h4").Resize(UBound(Result), UBound(Result, 2)) = Result
    
47.         For Each t In dic.keys
    
48.             dic(t) = Split(t, "|")
    
49.         Next
    
50.         Result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
    
51.         .Range("a4").Resize(UBound(Result), UBound(Result, 2)) = Result
    
52.         i = .Cells(Rows.Count, 1).End(xlUp).Row
    
53.         With .Range("a4:aa" & i).Borders
    
54.             .LineStyle = xlContinuous
    
55.         End With
    
56.     End With
    
57. End Sub

复制代码

hwc2ycy

工程明细表.rar (22.57 KB, 下载次数: 5)

2012-12-18 16:23 上传

点击文件名下载附件

hwc2ycy

楼主，数据录入时候还是规范点，不要在数据前面加上空格之类的。

hwc2ycy

1. Option Explicit
   
2. 
   
3. Sub 合并数据()
   
4.     Dim data
   
5.     '读源数据
   
6.     With Worksheets("Sheet1")
   
7.         data = .Range("a1").CurrentRegion
   
8.     End With
   
9. 
   
10.     '字典，装数据和列类别
    
11.     Dim dic As Object, dicItem As Object
    
12.     Set dic = CreateObject("scripting.dictionary")
    
13.     Set dicItem = CreateObject("scripting.dictionary")
    
14. 
    
15.     Dim arr1
    
16.     arr1 = Array("餐费", "早餐", " 午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", _
    
17.     "车费", "住宿费", "修理费", "工具费", "招待费", "水电", "项目检查费", "人情费", "合计", "联系人姓名", "联系人电话", "备注")
    
18.    
    
19.     '定义列坐标
    
20.     Dim t, i&
    
21.     For Each t In arr1
    
22.         i = i + 1
    
23.         dicItem(t) = i
    
24.     Next
    
25.     '以A|B列数据为KEY
    
26.     Dim StrKey$
    
27.     Dim Result(), iPos&
    
28.     For i = LBound(data) + 1 To UBound(data)    '第一行为标题
    
29.         StrKey = data(i, 1) & "|" & data(i, 2)
    
30.         If Not dic.exists(StrKey) Then      '检测字典中是否存在Strkey
    
31.             ReDim Result(1 To dicItem.Count)
    
32.             iPos = dicItem(data(i, 3))      '取列坐标
    
33.             Result(iPos) = data(i, 4)       '写入数据
    
34.             'If iPos > 1 And iPos < 6 Then Result(1) = data(i, 4)
    
35.             Result(dicItem.Count) = data(i, 5)  '备注
    
36.             dic(StrKey) = Result                '写入字典
    
37.         Else
    
38.             Result = dic(StrKey)                '取数组
    
39.             iPos = dicItem(data(i, 3))          '坐标
    
40.             Result(iPos) = Result(iPos) + data(i, 4)    '累加
    
41.             'If iPos > 1 And iPos < 6 Then Result(1) = Result(1) + data(i, 4)
    
42.             Result(dicItem.Count) = data(i, 5)  '备注
    
43.             dic(StrKey) = Result                '写回字典
    
44.         End If
    
45.     Next
    
46.    
    
47.     '结果数据写入Sheet3
    
48.     With Worksheets("Sheet3")
    
49.         i = .Cells(Rows.Count, 1).End(xlUp).Row '取最后一行数据位置
    
50.         If i > 3 Then .Range("a4:aa" & i).ClearContents '4为第一行数据位置
    
51.         Result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))    '数据经过2次转置变成2维数组
    
52.         .Range("h4").Resize(UBound(Result), UBound(Result, 2)) = Result                 '写入到H4
    
53.         
    
54.         '把KEY转变成一维数组，存入对应的ITEM
    
55.         For Each t In dic.keys
    
56.             dic(t) = Split(t, "|")
    
57.         Next
    
58.         
    
59.         'Items经过2次转换变成2维数组
    
60.         Result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
    
61.         .Range("a4").Resize(UBound(Result), UBound(Result, 2)) = Result '写入A4
    
62.         i = .Cells(Rows.Count, 1).End(xlUp).Row
    
63.         '添加边框
    
64.         With .Range("a4:aa" & i).Borders
    
65.             .LineStyle = xlContinuous
    
66.         End With
    
67.     End With
    
68. End Sub
    

复制代码

hwc2ycy

工程明细表.rar (23.18 KB, 下载次数: 8)

2012-12-18 16:32 上传

点击文件名下载附件

hwc2ycy

再来个数组的方法，效率应该比这高。

wucj80

这个已经很好了，老师，学习了,谢谢

wucj80

arr1 = Array("餐费", "早餐", " 午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", _

    "车费", "住宿费", "修理费", "工具费", "招待费", "水电", "项目检查费", "人情费", "合计", "联系人姓名", "联系人电话", "备注")

这一句中“宽带费", _   改成“宽带费", 这样可以吧，要不老是说这一句有问题

hwc2ycy

1. Sub 合并数据2()
   
2. '数组+字典解法
   
3. '2012-12-18 hwc2ycy 17:33修改
   
4.    
   
5.     Dim data
   
6.     '读源数据
   
7.     With Worksheets("Sheet1")
   
8.         data = .Range("a1").CurrentRegion
   
9.     End With
   
10. 
    
11.     '字典，装数据和列类别
    
12.     Dim dic As Object, dicItem As Object
    
13.     Set dic = CreateObject("scripting.dictionary")
    
14.     Set dicItem = CreateObject("scripting.dictionary")
    
15. 
    
16.     Dim arr1
    
17.     arr1 = Array("餐费", "早餐", " 午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", _
    
18.     "车费", "住宿费", "修理费", "工具费", "招待费", "水电", "项目检查费", "人情费", "合计", "联系人姓名", "联系人电话", "备注信息")
    
19.    
    
20.     '定义列坐标
    
21.     Dim t, i&
    
22.     i = 7
    
23.     For Each t In arr1
    
24.         i = i + 1
    
25.         dicItem(t) = i
    
26.     Next
    
27.     '以A|B列数据为KEY
    
28.     Dim StrKey$
    
29.     Dim Result(), iPos&, iCount&, k&
    
30.     ReDim Result(1 To 27, 1 To 1)
    
31.     For i = LBound(data) + 1 To UBound(data)    '第一行为标题
    
32.         StrKey = data(i, 1) & "|" & data(i, 2)
    
33.         If Not dic.exists(StrKey) Then      '检测字典中是否存在Strkey
    
34.             iCount = iCount + 1
    
35.             ReDim Preserve Result(1 To 27, 1 To iCount)
    
36.             iPos = dicItem(data(i, 3))      '取列坐标
    
37.             Result(iPos, iCount) = data(i, 4)      '写入数据
    
38.             Result(1, iCount) = data(i, 1)          'A列
    
39.             Result(2, iCount) = data(i, 2)          'B列
    
40.             'If iPos > 1 And iPos < 6 Then Result(1) = data(i, 4)
    
41.             Result(27, iCount) = data(i, 5)         '备注
    
42.             dic(StrKey) = iCount                    '写回字典
    
43.         Else
    
44.             k = dic(StrKey)                         '取数据列坐标
    
45.             iPos = dicItem(data(i, 3))              '行坐标
    
46.             Result(iPos, k) = Result(iPos, k) + data(i, 4)  '累加
    
47.             'If iPos > 1 And iPos < 6 Then Result(1) = Result(1) + data(i, 4)
    
48.             'Result(27, k) = data(i, 5)              '备注
    
49. 
    
50.         End If
    
51.     Next
    
52.    
    
53.     '结果数据写入Sheet3
    
54.     With Worksheets("Sheet3")
    
55.         i = .Cells(Rows.Count, 1).End(xlUp).Row '取最后一行数据位置
    
56.         If i > 3 Then .Range("a4:aa" & i).ClearContents '4为第一行数据位置
    
57.         
    
58.         '数组经转置后写回.
    
59.         .Range("a4").Resize(iCount, 27) = WorksheetFunction.Transpose(Result)
    
60.         
    
61.         i = .Cells(Rows.Count, 1).End(xlUp).Row
    
62.         '添加边框
    
63.         With .Range("a4:aa" & i).Borders
    
64.             .LineStyle = xlContinuous
    
65.         End With
    
66.         .Range("b4:b" & i).NumberFormatLocal = "yyyy年m月d日"   '设置日期格式
    
67.     End With
    
68. End Sub

复制代码