建筑幕墙单元体.组装件.零部件计算.查询器（Excel VBA版）

​前言：

本篇是建筑幕墙零部件计算器（Excel版）的使用说明书。

零部件计算与查询器为建筑幕墙设计专用程序，适用于有查询及算料需求的幕墙设计或工厂算料人员使用。（程序亦适用于迭代递归的材料计算）

程序的主要功能有：

1，查询单元体，组装件，零部件，玻璃的各项参数（如描述尺寸等），并标识错误数据。

2，根据单元体或者组装件的数量，快速计算其零部件的数量。

3，根据零部件编号，反向查询其应用位置，快速知晓零部件所影响的范围。

4，根据单元体，组装件，零部件，玻璃的编号数量，进行查询并分类汇总排序。

5，特殊用法，编号数量的分类汇总（无论编号是否在数据库中，均可分类汇总）

6，有数据库的，可快速链接数据库各项数据，方便使用数据。

版本适用：Excel版是用Office2016版开发的，理论上Office2010以上版本都可以使用，WPS未测试（使用结果未知）。

性能说明：根据程序设计，正向计算比反向查询耗时更少，反向模糊查询最慢。对计算影响最大的是，Assy表格数据量，其数据条数越大，编号嵌套级数越多，计算速度越慢。

普通情况下，数据库数据在几千条时，无论正向计算反向查询还是模糊查询，均只需要不到0.5秒即可计算完成（如果有0.1秒以下计算完成的，敬请留言）。

经极限测试，数据量总条数在7万时（Assy：5.1万条，Part：1.8万条，Glass：900条），程序仍可良好运行，正向计算时间在2秒完成，少量反向查询也只耗时2秒完成，大量的反向查询耗时会更多。而模糊查询由于匹配的编号数量不确定，耗时情况不确定，大致需要60秒完成。由于手头没有更大数据库，无法做更大测试。当然一般而言，反向查询多为单个编号查询。如果有更大数据库的，欢迎测试后留言。

（PS：反向查询及模糊查询性能考虑在在下一版程序中，进一步更新算法，加强其性能，使之与正向计算性能相当。作者业余更新，近期有其他安排，可能会拖更到元旦前后。）

本篇使用说明书，分三个方面介绍：

一，使用说明；

二，代码原理与设计说明；

三，源代码分享。

自述：一般来说直接使用Access制作数据计算与查询比用Excel更便捷简单，但是一般就办公环境而言，大多数人可能都没有安装Access，因此Excel的试用性反而更广，操作起来更为熟悉便利。另外建筑幕墙零部件数据量通常只有几万条，甚至少的话，只有几千条。秉承越简单越便捷，因此用Excel处理几万条数据性能已经足够了。之前发布（CMD版）时，Excel版的计算功能其实早已制作完成，但是我个人不太满意，于是又大改了一番，并加入了零部件反向查询功能，另外对几种特殊使用情况产生的Bug进行了修复。总体上此版本已经比较完善。一般情况下计算都是秒出，当然这个跟数据库的大小以及每个人的计算机有关，我的是笔记本，计算速度算是偏下。（程序下载链接获取方式在文章结尾处）

以下是计算器界面截图：

以下是视频使用说明：（视频横屏，有些模糊，建议放大到全屏播放）

为赶路人干杯.

---

文字版使用说明

一，使用说明

（1）文件介绍及前期准备

压缩包打开后的两个文件 （附件数据库，只是示意文件，下载试用后请删除！）

零部件计算器本身是在PisaAccess数据库基础上开发的，没有数据库的话会不太方便，当然也可以修改代码，适配不同的数据格式。

首次打开，启用数据链接。

(1.1) 有数据库的

将原数据库替换成自己的数据库文件，然后点击“更新数据源”按钮。

特别说明：更新数据源，只是将数据库中的数据复制到表格中，不会对数据库造成影响。

(1.2) 没有数据库文件的

需要填写 Assy,Part,Glass三个工作表，填写后的数据表，一定要用其他表格备份或者将表格另外导出，以免程序错误或者失效导致原始数据丢失！！！切记备份！

工作表 Assy

工作表 Part

工作表 Glass

（工作表Glass，可以不填数据，但请保留表头，以利程序运行。）

(2) 计算说明

(2.1) 正向计算

正向计算说明：

“正向计算”选项，是指用根据单元体或组件编号数量，计算所需的零部件编号和数量。

“玻璃”选项：勾选则计算结果包含玻璃，反之不含。

“描述”选项：勾选则计算结果包含描述，反之不含。

“DimA”选项：勾选则计算结果包含DimA，反之不含。

“DimB”选项：勾选则计算结果包含DimA，反之不含。

填入待计算单元体或者组装件，然后点击“零部件计算”即可。（详情可查看视频）

(2.2) 反向查询

反向查询说明：

“反向查询”选项，是指用零部件查询：单元体或组装件中的零部件使用情况。

查询关系为：零部件--查--组件，组件--查--单元体，层层递进，直到查询到最后一层。

“反向查询”默认为精确查询,勾选“模糊”选项为模糊查询。

“模糊”查询如果编号有多项，且存在正确与错误的编号，错误编号将不会在结果中显示。

“反向查询”的结果：

“第0级”时：“数量”为零部件的汇总数量，“描述”及“尺寸”均属零部件。

“第1级”时：“数量”为零部件在单元体或组装件中的数量，“描述”及“尺寸”均属单元体或组装件。

“第2级”时：“数量”为组装件在单元体中数量，“描述”及“尺寸”均属单元体。以此类推。

填入待查询的零件或者组装件，然后点击“零部件计算”即可。（详情可查看视频）

反向查询，不需要数量，如果有多个编号且存在数量，同样会被分类去重汇总

(3) 其他特殊用法

反向查询中的模糊查询以及其他特殊用法，请查看视频。

---

二，代码原理与设计说明

Excel版是用Office2016版开发了，理论上Office2010以上版本都可以 使用，WPS未测试（使用结果未知）。

程序运行流程示意（正向计算）（没有找到好的工具绘制，流程大致如此）

基本原理是使用VBA数组与字典，然后循环判断出相应的零部件编号，在对编号进行相应的累加汇总，最后排序。反向计算原理也是类似的，只是反向索引而已。因为是遍历整个数据表，因此原始数据越大，电脑运行速度越慢，计算速度也就越慢。

整个过程编程并不复杂，最为麻烦的是特殊使用场景下的BUG.

例如以下情况的处理，计算表中含空格，需要要标识出来，数量列有的填了数量，有的填错了，有的在正向计算中没有问题，但是在反向查询中或者模糊反向查询中又有问题，还有就是如果数据源中没有相关编号或者数据源存在问题，这些就是程序中需要修正的BUG. 另外程序在不同选项中的逻辑怎么安排，相关代码顺序一调换，结果完全不同。

---

三，原代码分享（正向计算源代码）

源代码几经精简，删除注释和空格后，仍然有六百多条。实在太多了，所以就放个关键正向计算代码，另外代码需要设置相关按钮，直接复制是无法使用的，有兴趣的同学可自行研究，并找出明显的BUG。

'正向计算
Sub Forward()
    '声明数组
    Dim Assy, Part, Glass, List, Count，
    Assy = Sheet1.Range("A1").CurrentRegion.Value
    Part = Sheet2.Range("A1").CurrentRegion.Value
    Glass = Sheet3.Range("A1").CurrentRegion.Value
    List = Sheet4.Range("A1", Range("A1048576").End(xlUp).Offset(0, 1)).Value
​
    '声明字典及循环参数
    Dim Dic As Object, Key$, D_key, D_item, n&, i&, j&, k&, Rng As Range，
​
    Set Dic = CreateObject("Scripting.Dictionary")
    k = 0
​
   '第0级,去空行，去重汇总
    For i = 2 To UBound(List, 1) Step 1
        Key = List(i, 1)
        If Dic.exists(Key) Then
            Dic.Item(Key) = Dic.Item(Key) + List(i, 2)
        Else
            Dic.Add Key, List(i, 2)
        End If
    Next
​
    n = Dic.Count
    D_key = Dic.Keys
    D_item = Dic.Items
    ReDim Count(1 To n, 1 To 6)
    '录入数组
    For i = 1 To n Step 1
        For j = 2 To UBound(Part, 1) Step 1
            If D_key(i - 1) = Part(j, 1) Then
                Count(i, 1) = Part(j, 1)
                Count(i, 2) = Part(j, 2)
                Count(i, 3) = Part(j, 3)
                Count(i, 4) = Part(j, 4)
                Count(i, 5) = D_item(i - 1)
                Count(i, 6) = "第 " & k & " 级"
            End If
        Next
    Next
​
    '判断是否录入玻璃
    If Sheet4.CheckBox1.Value = True Then
    For i = 1 To n Step 1
        For j = 2 To UBound(Glass, 1) Step 1
            If Count(i, 1) = Glass(j, 1) Then
                Count(i, 2) = Glass(j, 2)
                Count(i, 3) = Glass(j, 3)
                Count(i, 4) = Glass(j, 4)
            End If
        Next
    Next
    Else
    For i = 1 To n Step 1
        For j = 2 To UBound(Glass, 1) Step 1
            If Count(i, 1) = Glass(j, 1) Then
                Count(i, 1) = ""
                Count(i, 2) = ""
                Count(i, 3) = ""
                Count(i, 4) = ""
                Count(i, 5) = ""
                Count(i, 6) = ""
            End If
        Next
    Next
    End If
​
    '检查原始数据是否存在异常
    For i = 1 To n Step 1
        If D_key(i - 1) <> "" And D_key(i - 1) <> Count(i, 1) Then
            Count(i, 1) = D_key(i - 1)
            Count(i, 2) = "警告！此编号无数据源，请检查！并添加数据源！"
            Count(i, 3) = "无数据源！"
            Count(i, 4) = "无数据源！"
            Count(i, 5) = D_item(i - 1)
            Count(i, 6) = "第 " & k & " 级"
        ElseIf D_key(i - 1) = "" Then
            Count(i, 1) = "`Nothing"
            Count(i, 2) = "警告！计算区域存在空行！（注：空行不影响计算结果）"
            Count(i, 3) = "存在空行！"
            Count(i, 4) = "存在空行！"
            Count(i, 5) = ""
            Count(i, 6) = "第 " & k & " 级"
        End If
    Next
​
    '录入表格
    Set Rng = Sheet4.Range("G1048576").End(xlUp).Offset(1, 0).Resize(n, 6)
    Rng = Count
    Rng.Sort Rng.Cells(1, 1), xlAscending, Header:=xlNo
   '第N级,去重汇总
Loopp:
    k = k + 1
    Erase Count
    Dic.RemoveAll
​
    For i = 1 To UBound(D_key) + 1 Step 1
        For j = 2 To UBound(Assy, 1) Step 1
            If D_key(i - 1) = Assy(j, 1) Then
                Key = Assy(j, 2)
                    If Dic.exists(Key) Then
                        Dic.Item(Key) = Dic.Item(Key) + D_item(i - 1) * Assy(j, 3)
                    Else
                        Dic.Add Key, D_item(i - 1) * Assy(j, 3)
                    End If
            End If
        Next
    Next
​
    If n > 0 Then
        D_key = Dic.Keys
        D_item = Dic.Items
        ReDim Count(1 To n, 1 To 6)
    Else
        GoTo Endd
    End If
​
    For i = 1 To n Step 1
        For j = 2 To UBound(Part, 1) Step 1
            If D_key(i - 1) = Part(j, 1) Then
                Count(i, 1) = Part(j, 1)
                Count(i, 2) = Part(j, 2)
                Count(i, 3) = Part(j, 3)
                Count(i, 4) = Part(j, 4)
                Count(i, 5) = D_item(i - 1)
                Count(i, 6) = "第 " & k & " 级"
            End If
        Next
    Next
​
    If Sheet4.CheckBox1.Value = True Then
    For i = 1 To n Step 1
        For j = 2 To UBound(Glass, 1) Step 1
            If Count(i, 1) = Glass(j, 1) Then
                Count(i, 2) = Glass(j, 2)
                Count(i, 3) = Glass(j, 3)
                Count(i, 4) = Glass(j, 4)
            End If
        Next
    Next
    Else
    For i = 1 To n Step 1
        For j = 2 To UBound(Glass, 1) Step 1
            If Count(i, 1) = Glass(j, 1) Then
                Count(i, 1) = ""
                Count(i, 2) = ""
                Count(i, 3) = ""
                Count(i, 4) = ""
                Count(i, 5) = ""
                Count(i, 6) = ""
            End If
        Next
    Next
    End If
​
    For i = 1 To n Step 1
        If D_key(i - 1) <> Count(i, 1) Then
            Count(i, 1) = D_key(i - 1)
            Count(i, 2) = "警告！此编号无数据源，请检查！并添加数据源！"
            Count(i, 3) = "无数据源！"
            Count(i, 4) = "无数据源！"
            Count(i, 5) = D_item(i - 1)
            Count(i, 6) = "第 " & k & " 级"
        End If
    Next
​
    Set Rng = Sheet4.Range("G1048576").End(xlUp).Offset(2, 0).Resize(n, 6)
    Rng = Count
    Rng.Sort Rng.Cells(1, 1), xlAscending, Header:=xlNo
    GoTo Loopp
​
Endd:
    Erase Assy
    Erase Part
    Erase Glass
    Erase List
    Dim Warn
    Warn = Sheet4.Range("H1", Sheet4.Range("H1048576").End(xlUp))
​
    For i = 1 To UBound(Warn) Step 1
        If Warn(i, 1) Like "警告*" = True Then
            Sheet4.Range("G" & i, "L" & i).Interior.Color = 65535
            If Sheet4.CheckBox2.Value = False And Sheet4.CheckBox3.Value = False And Sheet4.CheckBox4.Value = False Then
                Sheet4.Range("G" & i).AddComment text:="警告！" & Chr(10) & "此编号无数据源！"
                Sheet4.Range("G" & i).Comment.Visible = False
            End If
        End If
    Next
​
    Erase Warn
    If Sheet4.CheckBox4.Value = False Then
        Sheet4.Columns("J:J").Delete
    End If
​
    If Sheet4.CheckBox3.Value = False Then
        Sheet4.Columns("I:I").Delete
    End If
​
    If Sheet4.CheckBox2.Value = False Then
        Sheet4.Columns("H:H").Delete
    End If
End Sub

---

结尾

以下为程序下载链接获取方式：

公众号：为赶路人干杯   

回复：零部件计算器

（文件下载后有可能会被电脑安全软件查杀，需要选择信任，并启用宏。）

请试用程序过后，麻烦大家投个票，做一个程序欢迎度调查，以便进一步改进程序。（初版程序难免有些Bug，投票留言赞赏将优先试用下一版更新程序）（另外作者想对程序欢迎度及使用次数进行简单统计，而程序本身不联网，因此加入了几个简单的验证码用于程序测试。请知悉！）

（最后要补充的是，分享程序时，请尽量 直接转发文章 或者使用 公众号回复的获取下载链接 分享，以保证原始程序的一致性，以免出错。直接转发下载好的程序，有可能会导致程序出错，无法使用，敬请留意。此版程序免费，考虑到使用体验，未进行.dll加密处理，有兴趣的自行研究，但严禁盗用程序进行商业倒卖。）

如发现有使用问题，请在本篇说明下面留言，或者公众号留言。

如果觉得程序有用，请一键三连，在看点赞收藏，并转发给有需要的人，希望程序能帮助到更多的设计人员。

此程序为专业幕墙设计的业余程序作品，原创编辑不易，我手写我心，你赏表你心。

最后的最后，希望程序对您所帮助。