[已解决]工程明细数

hwc2ycy · 发表于 2012-12-18 17:35

wucj80 发表于 2012-12-18 17:27
arr1 = Array("餐费", "早餐", " 午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", _

"车费", ...

那是另起一行的意思。

hwc2ycy · 发表于 2012-12-18 17:38

本帖最后由 hwc2ycy 于 2012-12-22 10:26 编辑

Sub 合并数据2()
'数组+字典解法
'2012-12-18 hwc2ycy 17:33修改
Dim data
'读源数据
With Worksheets("Sheet1")
data = .Range("a1").CurrentRegion
End With
'字典，装数据和列类别
Dim dic As Object, dicItem As Object
Set dic = CreateObject("scripting.dictionary")
Set dicItem = CreateObject("scripting.dictionary")
Dim arr1
arr1 = Array("餐费", "早餐", " 午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", _
"车费", "住宿费", "修理费", "工具费", "招待费", "水电", "项目检查费", "人情费", "合计", "联系人姓名", "联系人电话", "备注信息")
'定义列坐标
Dim t, i&
i = 7
For Each t In arr1
i = i + 1
dicItem(t) = i
Next
'以A|B列数据为KEY
Dim StrKey$
Dim Result(), iPos&, iCount&, k&
ReDim Result(1 To 27, 1 To 1)
For i = LBound(data) + 1 To UBound(data) '第一行为标题
StrKey = data(i, 1) & "|" & data(i, 2)
If Not dic.exists(StrKey) Then '检测字典中是否存在Strkey
iCount = iCount + 1
ReDim Preserve Result(1 To 27, 1 To iCount)
iPos = dicItem(data(i, 3)) '取列坐标
Result(iPos, iCount) = data(i, 4) '写入数据
Result(1, iCount) = data(i, 1) 'A列
Result(2, iCount) = data(i, 2) 'B列
'If iPos > 1 And iPos < 6 Then Result(1) = data(i, 4)
Result(27, iCount) = data(i, 5) '备注
dic(StrKey) = iCount '写回字典
Else
k = dic(StrKey) '取数据列坐标
iPos = dicItem(data(i, 3)) '行坐标
Result(iPos, k) = Result(iPos, k) + data(i, 4) '累加
'If iPos > 1 And iPos < 6 Then Result(1) = Result(1) + data(i, 4)
'Result(27, k) = data(i, 5) '备注
End If
Next
'结果数据写入Sheet2
With Worksheets("Sheet2")
i = .Cells(Rows.Count, 1).End(xlUp).Row '取最后一行数据位置
If i > 3 Then .Range("a4:aa" & i).Clear '4为第一行数据位置
'数组经转置后写回.
.Range("a4").Resize(iCount, 27) = WorksheetFunction.Transpose(Result)
i = .Cells(Rows.Count, 1).End(xlUp).Row
'添加边框
With .Range("a4:aa" & i).Borders
.LineStyle = xlContinuous
End With
.Range("b4:b" & i).NumberFormatLocal = "yyyy年m月d日" '设置日期格式
End With
End Sub

复制代码

改回来，写入SHEET2里。我的SHEET是因为复制了表头。

wucj80 · 发表于 2012-12-18 19:55

再一次多谢老师的答案。这一个也是很好的

wucj80 · 发表于 2012-12-20 23:16

老师有一个问题就是怎么会出现运行时错误，下标越界

wucj80 · 发表于 2012-12-21 00:51

那个问题就是第35行不能有什么数据，一有数据就是下标越界，请问一下老师这个问题怎么改决

wucj80 · 发表于 2012-12-22 01:13

工程明细表20121220

hwc2ycy · 发表于 2012-12-22 10:46

Sub 合并数据2()
'字典+数组，字典只存位置
'2012-12-22 by hwc2ycy
Dim data
'读源数据
With Worksheets("Sheet1")
data = .Range("a1").CurrentRegion
End With
'字典，装数据和列类别
Dim dic As Object, dicItem As Object
Set dic = CreateObject("scripting.dictionary")
Set dicItem = CreateObject("scripting.dictionary")
Dim arr1
arr1 = Array("餐费", "早餐", "午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", _
"车费", "住宿费", "修理费", "工具费", "招待费", "水电", "项目检查费", "人情费", "合计", "联系人姓名", "联系人电话", "备注信息")
'定义列坐标
Dim t, i&
i = 7
For Each t In arr1
i = i + 1
dicItem(t) = i
Next
'以A|B列数据为KEY
Dim StrKey$
Dim Result(), iPos&, iCount&, k&
ReDim Result(1 To 27, 1 To 1)
For i = LBound(data) + 1 To UBound(data) '第一行为标题
StrKey = data(i, 1) & "|" & data(i, 2)
If Not dic.exists(StrKey) Then '检测字典中是否存在Strkey
iCount = iCount + 1
ReDim Preserve Result(1 To 27, 1 To iCount)
If dicItem.exists(data(i, 3)) Then
iPos = dicItem(data(i, 3)) '取列坐标
Result(iPos, iCount) = data(i, 4) '写入数据
Result(1, iCount) = data(i, 1) 'A列
Result(2, iCount) = data(i, 2) 'B列
Result(27, iCount) = data(i, 5) '备注
dic(StrKey) = iCount '写回字典
Else
MsgBox "字段名" & "'" & data(i, 3) & "'" & " 有误，此条数据被忽略" & vbCr & " 点确定继续"
End If
Else
k = dic(StrKey) '取数据列坐标
If dicItem.exists(data(i, 3)) Then
iPos = dicItem(data(i, 3)) '行坐标
Result(iPos, k) = Result(iPos, k) + data(i, 4) '累加
Else
MsgBox "字段名" & "'" & data(i, 3) & "'" & " 有误，此条数据被忽略"
End If
End If
Next
'结果数据写入Sheet2
With Worksheets("Sheet2")
i = .Cells(Rows.Count, 1).End(xlUp).Row '取最后一行数据位置
If i > 3 Then .Range("a4:aa" & i).Clear '4为第一行数据位置
'数组经转置后写回.
.Range("a4").Resize(iCount, 27) = WorksheetFunction.Transpose(Result)
i = .Cells(Rows.Count, 1).End(xlUp).Row
'添加边框
With .Range("a4:aa" & i).Borders
.LineStyle = xlContinuous
End With
.Range("b4:b" & i).NumberFormatLocal = "yyyy年m月d日" '设置日期格式
End With
End Sub

复制代码

hwc2ycy · 发表于 2012-12-22 10:47

Option Explicit
Sub 合并数据()
'字典装数组
'2012-12-22 by hwc2ycy
Dim data
With Worksheets("Sheet1")
data = .Range("a1").CurrentRegion
End With
Dim dic As Object, dicItem As Object
Set dic = CreateObject("scripting.dictionary")
Set dicItem = CreateObject("scripting.dictionary")
Dim arr1
arr1 = Array("餐费", "早餐", "午餐", "晚餐", "夜宵", "生活用品", "煤气", "宽带费", "车费", "住宿费", "修理费", "工具费", "招待费", "水电", "项目检查费", "人情费", "合计", "联系人姓名", "联系人电话", "备注")
Dim t, i&
For Each t In arr1
i = i + 1
dicItem(t) = i
Next
Dim StrKey$
Dim Result(), iPos&
For i = LBound(data) + 1 To UBound(data)
StrKey = data(i, 1) & "|" & data(i, 2)
If Not dic.exists(StrKey) Then
ReDim Result(1 To dicItem.Count)
If dicItem.exists(data(i, 3)) Then
iPos = dicItem(data(i, 3))
Result(iPos) = data(i, 4)
'If iPos > 1 And iPos < 6 Then Result(1) = data(i, 4)
Result(dicItem.Count) = data(i, 5)
dic(StrKey) = Result
Else
MsgBox "字段名" & "'" & data(i, 3) & "'" & " 有误，此条数据被忽略" & "点确定继续"
End If
Else
Result = dic(StrKey)
If dicItem.exists(data(i, 3)) Then
iPos = dicItem(data(i, 3))
Result(iPos) = Result(iPos) + data(i, 4)
'If iPos > 1 And iPos < 6 Then Result(1) = Result(1) + data(i, 4)
Result(dicItem.Count) = data(i, 5)
dic(StrKey) = Result
Else
MsgBox "字段名" & "'" & data(i, 3) & "'" & " 有误，此条数据被忽略" & vbCr & "点确定继续"
End If
End If
Next
With Worksheets("sheet2")
i = .Cells(Rows.Count, 1).End(xlUp).Row
If i > 3 Then .Range("a4:aa" & i).ClearContents
Result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
.Range("h4").Resize(UBound(Result), UBound(Result, 2)) = Result
For Each t In dic.keys
dic(t) = Split(t, "|")
Next
Result = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
.Range("a4").Resize(UBound(Result), UBound(Result, 2)) = Result
i = .Cells(Rows.Count, 1).End(xlUp).Row
With .Range("a4:aa" & i).Borders
.LineStyle = xlContinuous
End With
End With
End Sub

复制代码

hwc2ycy · 发表于 2012-12-22 10:48

原来的代码中“午餐”前面多加了个空格，所以没有测出来。
代码重新改了，多谢。

hwc2ycy · 发表于 2012-12-22 10:49

工程明细表22.rar (20.49 KB, 下载次数: 7)

		自动登录	找回密码
密码			注册