【VBA字典数组201301班】练习
本帖最后由 JLxiangwei 于 2014-1-14 12:15 编辑大家试试看
本帖最后由 CheryBTL 于 2013-11-20 22:15 编辑
先占个沙发，
按汇总表进行汇总，多出的忽略：Sub 练习()
Dim ar, ar2, re, d As Object
Dim i As Integer, j As Integer, C As Integer
Dim colnum As Integer, str As String
Set d = CreateObject("Scripting.Dictionary")
colnum = Sheets(2).Cells(1, 256).End(xlToLeft).Column
ar = Sheets(1).Range("A2:B36")
ReDim re(1 To UBound(ar), 1 To 6)
For i = 1 To UBound(ar)
If ar(i, 2) = "" Then str = ar(i, 1)
If ar(i, 1) = "" Then ar(i, 1) = str & ar(i, 2)
d(ar(i, 1)) = i
Next i
For i = 1 To colnum Step 4
With Sheets(2)
ar2 = .Range(.Cells(2, i), .Cells(..End(3).Row, i + 2))
End With
C = Int((i - 1) / 4) + 1
For j = 1 To UBound(ar2)
If d.exists(ar2(j, 1) & ar2(j, 2)) Then
re(d(ar2(j, 1) & ar2(j, 2)), C) = ar2(j, 3)
re(d(ar2(j, 1)), C) = re(d(ar2(j, 1)), C) + ar2(j, 3)
re(UBound(re), C) = re(UBound(re), C) + ar2(j, 3)
End If
Next j
Next i
Sheets(1).Range("C2:H36") = re
End Sub表头自动生成的代码是练习，练习1是根据以上调整的结果：Sub 练习()
Dim d As Object
Dim ar, re(1 To 200, 1 To 2) 're即为表头
Dim i As Integer, j As Integer, m As Integer
Dim colnum As Integer, str As String
Sheets(1).Range("A2:H65536").ClearContents
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To 20
d(8200 + i) = ""
Next i
colnum = Sheets(2).Cells(1, 256).End(xlToLeft).Column
ar = Sheets(1).Range("A2:B36")
For i = 1 To colnum Step 4
With Sheets(2)
ar = .Range(.Cells(2, i), .Cells(..End(3).Row, i + 2))
End With
For j = 1 To UBound(ar)
If InStr(d(ar(j, 1)), ar(j, 2)) = 0 Then d(ar(j, 1)) = d(ar(j, 1)) & "," & ar(j, 2)
Next j
Next i
temp = d.Items
For i = 0 To UBound(temp)
If temp(i) <> "" Then
temp2 = Split(temp(i), ",")
For j = 0 To UBound(temp2)
m = m + 1
If temp2(j) = "" Then re(m, 1) = 8201 + i
re(m, 2) = temp2(j)
Next j
End If
Next i
re(m + 1, 2) = "合计"
Sheets(1)..Resize(UBound(re), 2) = re
练习1 '调用练习1，根据表头位置汇总数据
End Sub
Sub 练习1() '表头固定
Dim ar, ar2, re, d As Object
Dim i As Integer, j As Integer, C As Integer
Dim colnum As Integer, str As String, Rnum As Integer
Set d = CreateObject("Scripting.Dictionary")
colnum = Sheets(2).Cells(1, 256).End(xlToLeft).Column
Rnum = Sheets(1)..End(3).Row
ar = Sheets(1).Range("A2:B" & Rnum)
ReDim re(1 To UBound(ar), 1 To 6)
For i = 1 To UBound(ar)
If ar(i, 2) = "" Then str = ar(i, 1)
If ar(i, 1) = "" Then ar(i, 1) = str & ar(i, 2)
d(ar(i, 1)) = i
Next i
For i = 1 To colnum Step 4
With Sheets(2)
ar2 = .Range(.Cells(2, i), .Cells(..End(3).Row, i + 2))
End With
C = Int((i - 1) / 4) + 1
For j = 1 To UBound(ar2)
If d.exists(ar2(j, 1) & ar2(j, 2)) Then
re(d(ar2(j, 1) & ar2(j, 2)), C) = ar2(j, 3)
re(d(ar2(j, 1)), C) = re(d(ar2(j, 1)), C) + ar2(j, 3)
re(UBound(re), C) = re(UBound(re), C) + ar2(j, 3)
End If
Next j
Next i
Sheets(1)..Resize(UBound(re), 6) = re
End Sub另外，因为第一列想按顺序输出，所以对源数据做了二次引用，等开贴学习别人的思路。 本帖最后由 缔造者 于 2013-11-21 07:45 编辑
Option Explicit
Sub lx()
Dim dic As Object
Dim rng As Range
Dim adds As String, sr As String
Dim arr, brr
Dim i As Long, j As Long, r As Long, m As Long
'创建字典
Set dic = CreateObject("scripting.dictionary")
'执行with语句
With Sheets("模拟结果")
'清除结果区域中的数值
.Range("c2:h36").ClearContents
'将结果区域赋值给变量brr，此时变量brr变为二维数组
brr = .Range("a1:h35")
'结束with语句
End With
'初始化变量m，并赋值为一个常量数值2
m = 2
'遍历“数据源”工作表中已使用区域的第一行的每个单元格
For Each rng In Sheets("数据源").UsedRange.Item(1).Resize(1, Sheets("数据源").UsedRange.Columns.Count)
'如果第一行某个单元格的月份的值等于11时，则将其单元格的地址用逗号连接起来，形成一个一维数组
If Month(rng) = "11" Then adds = adds & rng.Address(0, 0) & ","
'继续下一个
Next rng
'执行with语句，去除一维数组adds中的最后一个逗号，使其成为多区域单元格地址数组
With Sheets("数据源").Range(Left(adds, Len(adds) - 1))
'统计多区域范围的个数
j = .Areas.Count
'变量每个小区域
For i = 1 To j
'将每个小区域赋值给变量arr，此时变量arr变为二维数组
arr = .Areas(i).CurrentRegion
'变量数组arr
For r = 2 To UBound(arr)
'将数组arr的第一列与第二列用“-”号连接起来并赋值给变量sr，此时变量sr变为一个字符串
sr = arr(r, 1) & "-" & arr(r, 2)
'将字符串sr装入字典，其对应的项累加
dic(sr) = dic(sr) + arr(r, 3)
'继续下一个
Next r
'变量数组brr
For r = 2 To UBound(brr)
'如果字典中存在变量brr的第一列与第二列用“-”号连接起来的字符串
If dic.exists(brr(m, 1) & "-" & brr(r, 2)) Then
'将明细结果写入“模拟结果”工作表中对应的单元格
Sheets("模拟结果").Cells(r, i + 2) = dic(brr(m, 1) & "-" & brr(r, 2))
'对各明细结果求和
Sheets("模拟结果").Cells(m, i + 2).Formula = "=sum(r[" & r - m & "]c:rc)"
'结束判断
End If
'如果变量r的值大于2且数组brr的第一列不为空时，重新给变量m赋值，其值等于变量r的值
If r > 2 And brr(r, 1) <> "" Then m = r
'继续下一个
Next r
'清空字典，重新装入，防止出错
dic.RemoveAll
'重新初始化变量m
m = 2
'继续下一个
Next i
'结束with语句
End With
'计算合计
Sheets("模拟结果").Range("c36:h36").Formula = "=sum(r[-34]c:r[-1]c)/2"
End Sub
先交一个按固定格式的：Sub sellby2() '固定格式
Dim arr, brr
Dim d As New Dictionary, dd As New Dictionary
Dim i%, j%, icol%, irow%
Dim St$, Str$
With ThisWorkbook.Sheets("数据源")
irow = .Range("a" & Rows.Count).End(3).Row
icol = .Cells(2, Columns.Count).End(1).Column
arr = .Range("a1").Resize(irow, icol).Value
End With
With ThisWorkbook.Sheets("模拟结果")
.Range("c2").Resize(1000, 40).ClearContents
brr = .Range("a1").CurrentRegion.Value '将模拟结果的表格格式赋给一个数组brr
For i = 2 To UBound(brr)
If Not IsEmpty(brr(i, 1)) Then St = brr(i, 1)
d(IIf(brr(i, 2) = "合计", brr(i, 2), St & brr(i, 2))) = i '将“航班号&航段”作KEY，行号作ITEM,用以确定行号
Next i
For i = 3 To UBound(brr, 2)
dd.Add brr(1, i), i '将“日期”作KEY，列号作ITEM,用以确定列号
Next i
' Stop
For i = 2 To UBound(arr)
For j = 1 To UBound(arr, 2) Step 4 '对数据源进行行列的二次循环，对列循环时级数是4（对每一日期进行循环）
St = arr(i, j)
Str = St & arr(i, j + 1)
If d.Exists(St) And d.Exists(Str) Then '判断关键词如果存在，执行以下代码
brr(d(St), dd(arr(1, j))) = brr(d(St), dd(arr(1, j))) + arr(i, j + 2) '每一航班第天累计
brr(d(Str), dd(arr(1, j))) = brr(d(Str), dd(arr(1, j))) + arr(i, j + 2) '每一航班和航段每天累计
brr(d("合计"), dd(arr(1, j))) = brr(d("合计"), dd(arr(1, j))) + arr(i, j + 2) '每天累计
End If
Next j
Next i
' Stop
.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr '写入指定单元格
End With
Set d = Nothing '释放对象
Set dd = Nothing
End Sub
Sub 练习1()
Dim arr(1 To 1000, 1 To 4), arr1, brr, crr, drr
Dim x As Integer, y As Integer
Dim i As Integer, j As Integer
Dim d1 As New Dictionary, d2 As New Dictionary
Dim Mysum1, Mysum2, Mysum3, Mysum4, Mysum5, Mysum6
Sheets("数据源").Activate
x = Cells(1, Columns.Count).End(xlToLeft).Column + 3
y = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To y
For j = 1 To x Step 4
k = k + 1
arr(k, 1) = Cells(1, j)
arr(k, 2) = Cells(i, j)
arr(k, 3) = Cells(i, j + 1)
arr(k, 4) = Cells(i, j + 2)
Next j
Next i
For i = 1 To k
d2(arr(i, 1) & "/" & arr(i, 2) & "/" & arr(i, 3)) = d2(arr(i, 1) & "/" & arr(i, 2) & "/" & arr(i, 3)) + arr(i, 4)
Next i
ReDim arr1(1 To d2.Count, 1 To 4)
For j = 1 To d2.Count
arr1(j, 1) = Split(d2.Keys(j - 1), "/")(0)
arr1(j, 2) = Split(d2.Keys(j - 1), "/")(1)
arr1(j, 3) = Split(d2.Keys(j - 1), "/")(2)
arr1(j, 4) = d2.Items(j - 1)
Next j
For i = 1 To UBound(arr1)
If d1.Exists(arr1(i, 1)) = False Then
d1(arr1(i, 1)) = d1.Count + 1
End If
Next i
Sheets("模拟结果").Activate
brr = Range("a2:b36")
crr = Range("c2:h36")
For i = 1 To UBound(brr)
If brr(i, 1) = "" Then brr(i, 1) = brr(i - 1, 1)
For j = 1 To UBound(arr1)
If brr(i, 1) & "-" & brr(i, 2) = arr1(j, 2) & "-" & arr1(j, 3) Then
crr(i, d1(arr1(j, 1))) = arr1(j, 4)
End If
Next j
Next i
.Resize(UBound(crr), UBound(crr, 2)) = crr
drr = Range("a2:h36")
k = 0
For i = UBound(drr) To 1 Step -1
If drr(i, 1) = "" Then
k = k + 1
Else
For j = 1 To k
Mysum1 = Mysum1 + drr(i + j, 3)
Mysum2 = Mysum2 + drr(i + j, 4)
Mysum3 = Mysum3 + drr(i + j, 5)
Mysum4 = Mysum4 + drr(i + j, 6)
Mysum5 = Mysum5 + drr(i + j, 7)
Mysum6 = Mysum6 + drr(i + j, 8)
Next j
drr(UBound(drr), 3) = drr(UBound(drr), 3) + Mysum1
drr(UBound(drr), 4) = drr(UBound(drr), 4) + Mysum2
drr(UBound(drr), 5) = drr(UBound(drr), 5) + Mysum3
drr(UBound(drr), 6) = drr(UBound(drr), 6) + Mysum4
drr(UBound(drr), 7) = drr(UBound(drr), 7) + Mysum5
drr(UBound(drr), 8) = drr(UBound(drr), 8) + Mysum6
drr(i, 3) = Mysum1: Mysum1 = 0
drr(i, 4) = Mysum2: Mysum2 = 0
drr(i, 5) = Mysum3: Mysum3 = 0
drr(i, 6) = Mysum4: Mysum4 = 0
drr(i, 7) = Mysum5: Mysum5 = 0
drr(i, 8) = Mysum6: Mysum6 = 0
k = 0
End If
Next i
.Resize(UBound(drr), UBound(drr, 2)) = drr
End Sub
只会笨方法，重在参与 总算绕出来了，好晕啊，回头看看其他各位老师的办法：Option Explicit
Sub sellby() '不按格式
Dim arr, brr, crr(8200 To 8300), tempArr
Dim d As New Dictionary
Dim i%, j%, n%, m%, icol%, irow%
Dim St$, Str$
Dim a
With ThisWorkbook.Sheets("数据源")
irow = .Range("a" & Rows.Count).End(3).Row
icol = .Cells(2, Columns.Count).End(1).Column
arr = .Range("a1").Resize(irow, icol).Value
End With
ReDim tempArr(1 To icol / 4) '定义一个临时数组，用来放每天的数量统计
'====创建字典，航班号，航班号&航段作为KEY，每天的数据统计（临时数组tempArr）作为ITEM
d("合计") = tempArr '字典中增加一个KEY：合计
For i = 2 To UBound(arr) ''对数据源进行行列的二次循环，对列循环时级数是4（对每一日期进行循环）
For j = 1 To UBound(arr, 2) Step 4 '
crr(arr(i, j)) = 1 '将航班号作为数组标号，用来标记和排序
m = Int(j) / 4 + 1 '每天的标记数
'===对每一航班号进行小计
St = arr(i, j)
If d.Exists(St) Then
tempArr = d(St) '字典中已有的航班，将ITEM的值赋给临时数组
Else
ReDim tempArr(1 To icol / 4) '字典中已没有的航班，定义一个临时数组，用来放每天的数量统计
End If
tempArr(m) = tempArr(m) + arr(i, j + 2) '将当天的数量进行累计
d(St) = tempArr '累计的数据作为新的ITEM
'===对每一航班号&航段进行统计
Str = St & "|" & arr(i, j + 1)
If d.Exists(Str) Then
tempArr = d(Str)
Else
ReDim tempArr(1 To icol / 4)
End If
tempArr(m) = tempArr(m) + arr(i, j + 2)
d(Str) = tempArr
'===对每天的数量进行合计
tempArr = d("合计")
tempArr(m) = tempArr(m) + arr(i, j + 2)
d("合计") = tempArr
Next j
Next i
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
' Stop
'===将字典内的数据按要求写入数组brr
ReDim brr(1 To 100, 1 To 2 + UBound(arr, 2) / 4) '定义一个数组，用来放结果
'===表头
brr(1, 1) = "航班号": brr(1, 2) = "航段"
For j = 1 To UBound(arr, 2) Step 4
m = Int(j) / 4 + 1
brr(1, m + 2) = arr(1, j)
Next j
'===将各航班的数据写入
n = 1
For i = LBound(crr) To UBound(crr) '8200 To 8300 '对航班号数组进行循环
If crr(i) Then '如果该航班存在（即航班标记＝１）
For Each a In d.Keys '遍历字典的KEY
If InStr(a, i) Then'
n = n + 1
brr(n, 1) = IIf(InStr(a, "|"), "", a)
brr(n, 2) = IIf(InStr(a, "|"), Right(a, 6), "")
tempArr = d(a)
For m = 1 To icol / 4
brr(n, m + 2) = tempArr(m)
Next m
d.Remove (a) '移除该KEY
End If
Next
End If
Next i
' Stop
'===将合计数据写入
n = n + 1
brr(n, 2) = "合计"
tempArr = d("合计")
For m = 1 To icol / 4
brr(n, m + 2) = tempArr(m)
Next m
' Stop
'===写入指定单元格
With Sheets("模拟结果")
.Cells.ClearContents
.Range("a1").Resize(n, m + 1) = brr
End With
Set d = Nothing '释放对象
End Sub
页:
[1]