使用VBA小程序提高资产清查效率

dawn

已于 2023-04-23 15:24:55 修改

阅读量635

点赞数

分类专栏： VB + VBScript + VBA 文章标签： VBA 资产清查

于 2023-04-20 23:22:42 首次发布

本文链接：https://blog.csdn.net/dawn0718/article/details/130277772

版权

VB + VBScript + VBA 专栏收录该内容

18 篇文章 0 订阅

订阅专栏

　　资产清查是一件相当烦人的工作，去年使用LayUI+PHP+MS SQL Server 2014写了一个资产清查的程序，可惜写完了，LayUI已经停止更新了，就没有再完善下去，数据也没有更新，等于就废了。

　　今年又要进行资产清查，启用LayUI的程序，快一年没有弄了已经有些陌生了，也来不及整改了，就使用Excel的VBA来进行匹配。

　　资产清查，就是资产台账与实物记录进行匹配的，这个是很烦人的工作，因为资产台账和实物台账的数据都不一定准确，要核对好不是一件轻松的事情。

　　要手工去核对几乎不可能，比如1500条台账数据，实物也有1500条，核对上做上标记，看似简单，如果一个人做那么特别累，时间长也来不及，多人去做，数据怎样统一和共享是问题，所以，只能由程序来完成。

　　实际上工作中，这样的任务需要很短的时间去完成，没有必要开发一个系统来完成，因为界面部分就会耗去大量的时间，而直接使用Excel VBA就是一个不错的选择。

　　根据实际需要可以随时修改、优化程序，很大程度上提高了工作效率。

　　核对过程：

　　1、整理完整的资产台账和实物台账，要求数据必须准确、格式统一；

　　2、使用VBA小程序去匹配，可以按指定的条件去匹配，匹配上了就给实物发放一个资产编码；

　　3、最严格的匹配条件过后，可能有一些是匹配不上的，需要放松条件去匹配，匹配完成后针对匹配记录发放调配单。比如：因为某某原因，某一台设备由什么变为什么，由某一地点调配至另一地点等。

　　4、根据调配单更新资产台账和实物台账，匹配完成。

　　下面是代码部分：

　　主要涉及VBA的结构体传参、函数和过程调用、快速查找等功能。

　　⑴参数传递的结构体

'获取返回的信息结构体
Type StructGetInfo
    SDW As String   '单位名称
    SGGXH As String '规格型号
    SWZ As String   '位置
    SSYR As String  '使用人
    SRow As String  '匹配的行号
End Type

'参数传递的结构体
Type StructPara
    SDW As String   '单位名称
    SPP As String   '品牌
    SGGXH() As String '规格型号
    SSheetName As String    'sheet名称
    SSrcRow As String       '源数据行
    SZCBM As String         '资产编码
End Type

　　⑵定义共用的方法

Public Sub SetCellValue(SCellName As String, SValue As String)
    '设置单元格的值
    Range(SCellName).Select
    Selection.FormulaR1C1 = SValue
End Sub

Public Function GetCellValue(SCellName As String)
    '获取单元格的值
    Range(SCellName).Select
    GetCellValue = Selection.FormulaR1C1
End Function
Function ContainNumber(Str) As Boolean
    '判断字符串是否包含数字
    ContainNumber = False
    Dim Reg As Object
    Set Reg = CreateObject("vbscript.regexp")
    With Reg
        .Global = True
        .Pattern = "\d{1,}"
        ContainNumber = .Test(Str)
    End With
End Function

Function GetNumberFromChar(Str As String) As String
    '提取字符串中的数字，只提取第一个匹配的结果
    GetNumberFromChar = ""
    Dim Reg As Object
    Dim MatchResult As Object
    Dim ReturnStr As String
    Dim MatchItem As Object
    
    Set Reg = CreateObject("vbscript.regexp")
    With Reg
        .Global = True
        .Pattern = "\d{1,}"
        Set MatchResult = .Execute(Str)
        GetNumberFromChar = MatchResult(0)
'        If MatchResult.Count > 0 Then
'            For Each MatchItem In MatchResult
'                ReturnStr = ReturnStr + MatchItem
'            Next
'            GetNumberFromChar = ReturnStr
'        End If
    End With
End Function

Function ConvertArrToChar(Arr() As String)
    '将字符串数组转换为字符
    Dim IFor As Integer
    Dim IArrLength As Integer   '数组的长度
    Dim Str As String
    
    IArrLength = UBound(Arr) - LBound(Arr) + 1
    For IFor = 0 To IArrLength - 1
        Str = Str + " " + UCase(Arr(IFor))
    Next
    ConvertArrToChar = Str
End Function

　　⑶根据匹配条件进行匹配的函数

Public Function MatchAtMultiCol(MyStructPara As StructPara) As StructMatchInfo
    '根据传递的参数对表格记录进行匹配
    Dim MatchCell_DeviceType As Range, MatchCell_Brand As Range, MatchCell_UnitName As Range, MatchCell_AssetCode As Range, MatchCell_GGXH As Range
    Dim MatchCell_MatchRowSign As Range     '匹配行号
    Dim MatchCell_MatchType As Range        '匹配类型
    Dim MatchCell_MatchMemo As Range        '匹配说明
    Dim MatchCell_RealUnitname As Range     '实际的单位名称
    Dim MatchCell_RealGGXH As Range         '实际的规格型号
    Dim MatchCell_Position As Range         '位置
    Dim MatchCell_UserName As Range         '使用人
    Dim MatchCell_ActionMemo As Range       '操作说明
        
    Dim SMatchRowSign As String             '匹配的行号记录
    Dim SGGXH() As String
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim IFor As Integer
    Dim DawnMatchInfo As StructMatchInfo  '返回信息的结构体
        
    SGGXH = MyStructPara.SGGXH
    Set ws = Worksheets(MyStructPara.SSheetName)
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    '设置范围
    Set MatchCell_AssetCode = ws.Range("A2:A" & Trim(Str(LastRow)))     '资产编码
    Set MatchCell_DeviceType = ws.Range("B2:B" & Trim(Str(LastRow)))    '设备类型
    Set MatchCell_Brand = ws.Range("C2:C" & Trim(Str(LastRow)))         '品牌
    Set MatchCell_UnitName = ws.Range("D2:D" & Trim(Str(LastRow)))      '单位名称
    Set MatchCell_GGXH = ws.Range("E2:E" & Trim(Str(LastRow)))          '规格型号
    Set MatchCell_MatchRowSign = ws.Range("F2:F" & Trim(Str(LastRow)))  '记录匹配的行号
    Set MatchCell_MatchType = ws.Range("G2:G" & Trim(Str(LastRow)))     '匹配类型
    Set MatchCell_MatchMemo = ws.Range("H2:H" & Trim(Str(LastRow)))     '匹配说明
    Set MatchCell_RealUnitname = ws.Range("I2:I" & Trim(Str(LastRow)))  '实际单位
    Set MatchCell_RealGGXH = ws.Range("J2:J" & Trim(Str(LastRow)))      '实际规格型号
    Set MatchCell_Position = ws.Range("K2:K" & Trim(Str(LastRow)))      '具体位置
    Set MatchCell_UserName = ws.Range("L2:L" & Trim(Str(LastRow)))      '使用人
    Set MatchCell_ActionMemo = ws.Range("M2:M" & Trim(Str(LastRow)))    '操作说明
        
    DawnMatchInfo.SMatchRow = ""
    DawnMatchInfo.SAssetCode = ""
    MatchAtMultiCol = DawnMatchInfo
    
    For IFor = 1 To LastRow - 1
        SDeviceType = UCase(Trim(MatchCell_DeviceType(IFor).Value))
        SBrand = UCase(Trim(MatchCell_Brand(IFor).Value))
        SUnitName = UCase(Trim(MatchCell_UnitName(IFor).Value))
        StrGGXH = UCase(Trim(MatchCell_GGXH(IFor).Value))
        SMatchRowSign = UCase(Trim(MatchCell_MatchRowSign(IFor).Value))
        
        Select Case MyStructPara.SMatchMethod
                Case 1      '严格匹配
                    If SUnitName = MyStructPara.SUnitName And SDeviceType = MyStructPara.SDeviceType And SBrand = MyStructPara.SBrand And InStr(StrGGXH, SGGXH(0)) > 0 And InStr(StrGGXH, SGGXH(1)) > 0 And SMatchRowSign = "" Then
                        '记录
                        MatchCell_MatchRowSign(IFor).Value = MyStructPara.SSrcRow
                        MatchCell_MatchType(IFor).Value = MyStructPara.SMatchMethod
                        MatchCell_MatchMemo(IFor).Value = "√"
                        MatchCell_RealUnitname(IFor).Value = MyStructPara.SUnitName
                        MatchCell_RealGGXH(IFor).Value = ConvertArrToChar(MyStructPara.SGGXH)
                        MatchCell_Position(IFor).Value = MyStructPara.SPosition
                        MatchCell_UserName(IFor).Value = MyStructPara.SUser
                        MatchCell_ActionMemo(IFor).Value = ""
                                                
                        DawnMatchInfo.SMatchRow = Str(MatchCell_AssetCode(IFor).Row)
                        DawnMatchInfo.SAssetCode = Str(MatchCell_AssetCode(IFor).Value)
                        MatchAtMultiCol = DawnMatchInfo
                        Exit For
                    End If
                    
                Case 2
                        '
                    If SDeviceType = MyStructPara.SDeviceType And SBrand = MyStructPara.SBrand And InStr(StrGGXH, SGGXH(0)) > 0 And InStr(StrGGXH, SGGXH(1)) > 0 And SMatchRowSign = "" Then
                        '记录
                        MatchCell_MatchRowSign(IFor).Value = MyStructPara.SSrcRow
                        MatchCell_MatchType(IFor).Value = MyStructPara.SMatchMethod
                        MatchCell_MatchMemo(IFor).Value = "★"
                        MatchCell_RealUnitname(IFor).Value = MyStructPara.SUnitName
                        MatchCell_RealGGXH(IFor).Value = ConvertArrToChar(MyStructPara.SGGXH)
                        MatchCell_Position(IFor).Value = MyStructPara.SPosition
                        MatchCell_UserName(IFor).Value = MyStructPara.SUser
                        MatchCell_ActionMemo(IFor).Value = "资产调拨单"
                                                
                        DawnMatchInfo.SMatchRow = Str(IFor)
                        DawnMatchInfo.SAssetCode = Str(MatchCell_AssetCode(IFor).Value)
                        MatchAtMultiCol = DawnMatchInfo
                        Exit For
                    End If
                        
                Case 3
                        '
        End Select
        
    Next
End Function

　　⑷实际调用

Sub AssetVerify()
    'Dawn 2023年4月19日
    Dim DawnPara As StructPara              '参数传递的结构体
    Dim DawnMatchInfo As StructMatchInfo    '返回信息的结构体
    
    Dim IFor As Integer
    Dim iFindCount As Integer               '匹配的总数
    Dim DestRow As String                   '在目标表中匹配到的行号
    Dim allEquipment As Integer             '计算机资产表的记录数
    Dim SrcTable As String                  '计算机资产表的名称
    Dim Src_DWMC As String                  '源表的单位名称
    Dim Src_PP As String                    '源表的品牌
    Dim Src_GGXH() As String                '源表的规格型号
    Dim Src_ZCBM As String                  '源表的资产编码
        
    allEquipment = 355
    SrcTable = "实物表"
    DawnPara.SMatchMethod = 1   '单位、品牌、规格型号完全匹配，说明：★
    'DawnPara.SMatchMethod = 2   '品牌、规格型号完全匹配，说明：◎
    'DawnPara.SMatchMother = 3   '品牌、规格型号模糊匹配，说明：模糊匹配
    DawnPara.SSheetName = "资产表"
    
    For IFor = 2 To allEquipment
        '提取源表的单位名称、品牌、规格型号
        Sheets(SrcTable).Activate
        DawnPara.SUnitName = Trim(UCase(GetCellValue("B" + Trim(Str(IFor)))))            '单位名称
        DawnPara.SUser = Trim(UCase(GetCellValue("C" + Trim(Str(IFor)))))                '使用人
        DawnPara.SPosition = Trim(UCase(GetCellValue("D" + Trim(Str(IFor)))))            '位置
        DawnPara.SBrand = Trim(UCase(GetCellValue("E" + Trim(Str(IFor)))))               '品牌
        DawnPara.SDeviceType = Trim(UCase(GetCellValue("F" + Trim(Str(IFor)))))          '设备类型
        DawnPara.SGGXH = Split(Trim(UCase(GetCellValue("G" + Trim(Str(IFor))))), " ")    '规格型号
        DawnPara.SSrcRow = Str(IFor)
        
        If UBound(DawnPara.SGGXH) > 0 And DawnPara.SGGXH(0) <> "" Then
            DawnMatchInfo = MatchAtMultiCol(DawnPara)
            If DawnMatchInfo.SMatchRow <> "" Then
                Call SetCellValue("K" & Trim(Str(IFor)), DawnMatchInfo.SMatchRow)
                Call SetCellValue("L" & Trim(Str(IFor)), DawnMatchInfo.SAssetCode)
                iFindCount = iFindCount + 1
            End If
        End If
    Next
    
    MsgBox "核对完毕！匹配数：" + Str(iFindCount)
End Sub

Sub Init()
    Sheets("实物表").Activate
    For IFor = 2 To 356
        Call SetCellValue("K" & Trim(Str(IFor)), "")
        Call SetCellValue("L" & Trim(Str(IFor)), "")
    Next
    Sheets("资产表").Activate
    For IFor = 2 To 1020
        Call SetCellValue("F" & Trim(Str(IFor)), "")
        Call SetCellValue("G" & Trim(Str(IFor)), "")
        Call SetCellValue("H" & Trim(Str(IFor)), "")
        Call SetCellValue("I" & Trim(Str(IFor)), "")
        Call SetCellValue("J" & Trim(Str(IFor)), "")
        Call SetCellValue("K" & Trim(Str(IFor)), "")
        Call SetCellValue("L" & Trim(Str(IFor)), "")
        Call SetCellValue("M" & Trim(Str(IFor)), "")
    Next
End Sub

　　使用VBA程序核对起来很快，1500条数据不到1分钟就核对完成，在数据准确的情况下匹配率令人满意，关键是速度快，省去了不少的时间。
　　表面上这个问题似乎简单，但是实际运行过程中并不容易，比如：

　　⑴ 资产表中的规格型号为“ThinkcenterM8500TNO76（单屏”，实际的型号应该为"ThinkCentre M8500t-NO76",核心应该是"M8500tNO76"，那么就需要灵活处理，关键是提取其中的数字进行匹配。

　　⑵ 资产表中的规格型号为“联想ThinkCentreM8330TI5-2400”，实际的型号应该为"ThinkCentre M8330t",核心应该是"8330t"。

　　⑶ 资产表中的规格型号为“惠普 288 Pro G6 Microtower PC”，实际的型号应该为"288 Pro G6 MicrotowerPC",核心应该是"288"和"G6"。

　　⑷ 资产表中的规格型号为“LaserJet Pro MFP M227fdw”，核心应该是"M227fdw",因为这个型号的打印机还有“M227cdw“、"M227cdn"。

　　等等，太多了，也因为复杂一些，所以很喜欢VBA语言，根据不需要为界面而操作，调试也方便，真是再好不过如此了。

　　最方便的脚本语言可能就是JavaScript和VBA了（还有VBScript）。