|
|
楼主 |
发表于 2023-7-11 16:26
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub GenerateInventorySheet()
Dim r%, i%, m%
Dim arr, brr, hg(1 To 17)
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
'禁止屏幕更新和显示警告对话框
With Worksheets("出入库明细")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
' 获取出入库明细工作表中第一列最后一个非空单元格的行号
arr = .Range("A2:H" & r)
' 将出入库明细工作表中的数据区域存储在 arr 数组中
End With
' 将 arr 数组中的数据存储到字典对象 d 中
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
' 如果字典 d 中不存在以 arr(i, 1) 为键的项，则创建一个新的子字典
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 1)).exists(arr(i, 2)) Then
' 如果子字典 d(arr(i, 1)) 中不存在以 arr(i, 2) 为键的项，则创建一个新的二维数组 brr
m = 1
ReDim brr(1 To 6, 1 To m)
Else
' 子字典中已存在以 arr(i, 2) 为键的项，则获取对应的二维数组 brr
brr = d(arr(i, 1))(arr(i, 2))
m = UBound(brr, 2) + 1
ReDim Preserve brr(1 To 6, 1 To m)
End If
' 将 arr(i, j + 2) 的值赋给二维数组 brr 的相应位置
For j = 1 To 6
brr(j, m) = arr(i, j + 2)
Next
' 将更新后的数组 brr 存储回字典 d 中的相应位置
d(arr(i, 1))(arr(i, 2)) = brr
Next
q = 18
With Worksheets("出入库单")
' 处理出入库单工作表
For i = 1 To 17
hg(i) = .Rows(i).RowHeight
' 存储原始行高信息
Next
.Rows("18:" & .Rows.Count).Clear
' 清空出入库单工作表中的一部分区域
.Range("B2,F2,A4:F13,C14:F14") = ""
' 清空指定区域的数据
.Range("C14,E14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
'.Range("D14").FormulaR1C1 = "=R[-1]C"
.Range("A15").FormulaR1C1 = "大写金额"
' 设置一些单元格的公式
' 遍历字典 d 的键和值，将数据填充到出入库单工作表中
For Each aa In d.keys
For Each bb In d(aa).keys
brr = d(aa)(bb)
ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
' 转置数组 brr，存储到数组 crr 中
For i = 1 To UBound(brr)
For j = 1 To UBound(brr, 2)
crr(j, i) = brr(i, j)
Next
Next
m = 4
' 将数组 crr 的值写入出入库单工作表中的相应位置
For i = 1 To UBound(crr)
For j = 1 To UBound(crr, 2)
.Cells(m, j) = crr(i, j)
Next
If m = 4 Then
.Range("B2") = bb
.Range("F2") = aa
End If
m = m + 1
' 判断是否需要插入新的一组数据
If m > 13 Or i = UBound(crr) Then
.Range("A1:F16").Copy .Cells(q, 1)
' 设置复制的行高
For w = 1 To 17
.Rows(q + w - 1).RowHeight = hg(w)
Next
m = 4
q = q + 17
End If
Next
Next
Next
.Rows("1:17").Delete
' 删除原始的行号 1 到 17 的行
End With
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-7-11 16:26
