玖叶教程网

功能：在窗体各控件输入条件，从进货记录中抓取数据，一键生成部门盘点表。

需要原文件的朋友请在评论区留下电子邮箱地址。

窗体界面介绍：

1、年月：从数组载入，默认为当前的年份和月份，也可以下拉选择。

2、部门：在进货记录中，利用字典获取部门名称，并载入窗体中部门列表。

3、盘点种类：可多选要盘点的种类。

4、进货区间采样：以最近的几个月进货记录为样本，生成盘点表。

盘点表介绍：

1、自动生成表头及标题

2、自动生成数据（序号、品名、规格、单位、单价）

3、第二个部门的盘点表在右边一列生成（如下图）

代码：

'生成部门盘点表

Private Sub CommandButton1_Click()

On Error Resume Next

If Me.部门.Value = "" Then MsgBox "请选择部门！", vbCritical, "错误！": Exit Sub

If Me.年.Value = "" Then MsgBox "请选择年份！", vbCritical, "错误！": Exit Sub

If Me.月.Value = "" Then MsgBox "请选择月份！", vbCritical, "错误！": Exit Sub

If Me.CheckBox1.Value = False And Me.CheckBox2.Value = False And Me.CheckBox3.Value = False Then

MsgBox "请至少选择一个盘点种类！", vbCritical, "错误！": Exit Sub

End If

If Me.区间.Value = "" Then MsgBox "请选择进货采样区间！", vbCritical, "错误！": Exit Sub

Dim arr, i As Long, n As Long, dic As Object, brr(1 To 7), d, col As New Collection

Dim str1, str2 As Date

Set dic = CreateObject("scripting.dictionary")

'//////////////// 处理数据 ///////////////////

进货时间排序

arr = Sheets("进货记录").Range("A1").CurrentRegion

str1 = Me.部门.Value

str2 = Format(DateSerial(Me.年.Value, Me.月.Value + 1, 0), "yyyy/mm/dd") '本月最后一天日期

'根据复选框是否勾选确定盘点种类

Dim 盘点种类

For i = 1 To 3 '有3个复选框

If Me.Controls("checkbox" & i).Value = True Then

盘点种类 = 盘点种类 & "@" & Me.Controls("checkbox" & i).Caption

End If

Next i

For i = 2 To UBound(arr)

If VBA.InStr(盘点种类, arr(i, 5)) Then

brr(1) = arr(i, 6) '规格

brr(2) = arr(i, 7) '单位

brr(3) = arr(i, 9) '单价

brr(4) = ""

brr(5) = ""

brr(6) = arr(i, 4) '部门

brr(7) = arr(i, 1) '进货日期

dic(arr(i, 2) & arr(i, 4)) = brr

End If

Next

'遍历字典关键字，将所选部门的字典写入集合

Dim str3 As Date

'获取上个月第一天日期

str3 = Format(DateSerial(Me.年.Value, Me.月.Value - Me.区间.Value + 1, 1), "yyyy/mm/dd")

For Each d In dic.keys

If dic(d)(6) = str1 And dic(d)(7) >= str3 Then

col.Add d

End If

Next d

'///////////// 生成部门盘点表 ///////////////////////

'确定在哪一列生成盘点表

If Sheets("部门盘点表").Range("A4") = "" Then

列 = 1

Else

列 = Sheets("部门盘点表").Range("A4").End(xlToRight).Column + 1

End If

'表头

With Sheets("部门盘点表").Cells(1, 列)

.Value = "**公司 **店盘点表" & "【部门：" & str1 & "】"

.Resize(1, 8).Merge

.HorizontalAlignment = xlCenter

.Font.Size = 18

.RowHeight = 35

End With

'盘点日期

With Sheets("部门盘点表").Cells(2, 列)

.Value = "盘点时间：" & Format(str2, "yyyy/mm/dd")

.Resize(1, 8).Merge

.HorizontalAlignment = xlCenter

.Font.Size = 12

End With

'序号所在列

With Sheets("部门盘点表").Columns(列)

.HorizontalAlignment = xlCenter

.ColumnWidth = 5

End With

'单位所在列

With Sheets("部门盘点表").Columns(列 + 3)

.HorizontalAlignment = xlCenter

.ColumnWidth = 5

End With

'第四行

With Sheets("部门盘点表").Rows(4)

.HorizontalAlignment = xlCenter

End With

'加边框

最大行 = col.Count + 10

With Sheets("部门盘点表").Range(Cells(4, 列), Cells(最大行, 列 + 7))

.Borders.Color = RGB(0, 0, 0)

.Height = 16

End With

'表格标题

Sheets("部门盘点表").Cells(4, 列).Resize(1, 8) = Array("序号", "品 名", "规 格", "单位", "单价", "盘点数量", "金额", "备 注")

For i = 5 To col.Count + 4

cd = Len(col(i - 4)) - Len(str1)

Sheets("部门盘点表").Cells(i, 列) = i - 4 '序号

Sheets("部门盘点表").Cells(i, 列 + 1) = Left(col(i - 4), cd) '品名

Sheets("部门盘点表").Cells(i, 列 + 2).Resize(1, 3) = dic(col(i - 4)) '规格、单位、单价

Next i

'品名、规格两列自动调整列宽

Sheets("部门盘点表").Columns(列 + 1).EntireColumn.AutoFit

Sheets("部门盘点表").Columns(列 + 2).EntireColumn.AutoFit

MsgBox "【部门：" & Me.部门.Value & "】盘点表已生成！"

Me.部门.Value = ""

Set dic = Nothing

End Sub

需要原文件的朋友请在评论区留下电子邮箱地址。