使用VBA生成设备调拨单

dawn

已于 2023-05-23 12:41:22 修改

阅读量715

点赞数 1

分类专栏： VB + VBScript + VBA 文章标签： VBA ExcelVBA WordVBA

于 2023-04-26 23:48:46 首次发布

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

版权

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

18 篇文章 0 订阅

订阅专栏

　　处理完成资产核对以后，需要手工生成调拨单，就是资产表上的设备在别的单位，那么就应该生成设备调拨单。
　　这个工作简单，但是单位多的话，比如30个单位就可能有900张的设备调拨单，手工处理起来还是很费精力。
　　使用VBA可以替代手工操作。
　　1、读取调出单位和调入单位的设备记录信息

Function ReadyTransferInfo(STransferOut As String, STransferIn As String)
    '准备提取调出单位、调入单位的数据记录，返回一个二维数组
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim iFor As Integer
    Dim MatchCell_ZCBUnitname As Range      '资产表的单位名称
    Dim MatchCell_RealUnitname As Range     '实际的单位名称
    Dim MatchCell_AssetCode As Range        '资产编码
    Dim MatchCell_AssetName As Range        '资产名称
    Dim MatchCell_RealGGXH As Range         '实际的规格型号
    Dim MatchCell_FactoryDate As Range      '出厂日期
    Dim MatchCell_MeasureUnit As Range      '计量单位
    Dim MatchCell_InitMoney As Range        '账面原值
    Dim IArrCount As Integer
    Dim ZCBUnitName As String
    Dim RealUnitName As String
    Dim SAssetCode As String
    Dim SAssetName As String
    Dim RealGGXH As String
    Dim FactoryDate As String
    Dim MeasureUnit As String
    Dim InitMoney As String                 '账面原值
    Dim SInfoArr() As String
    Dim IArrLength As Integer               '判断需要定义数组的大小
        
    '设置范围
    Set ws = Worksheets("OK资产表")
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set MatchCell_ZCBUnitname = ws.Range("D2:D" & Trim(Str(LastRow)))   '资产表单位
    Set MatchCell_RealUnitname = ws.Range("H2:H" & Trim(Str(LastRow)))  '实际单位
    Set MatchCell_AssetCode = ws.Range("A2:A" & Trim(Str(LastRow)))     '资产编码
    Set MatchCell_AssetName = ws.Range("B2:B" & Trim(Str(LastRow)))     '资产名称
    Set MatchCell_RealGGXH = ws.Range("I2:I" & Trim(Str(LastRow)))      '实际规格型号
    Set MatchCell_FactoryDate = ws.Range("L2:L" & Trim(Str(LastRow)))   '出厂日期
    Set MatchCell_MeasureUnit = ws.Range("AD2:AD" & Trim(Str(LastRow))) '计量单位
    Set MatchCell_FactoryDate = ws.Range("L2:L" & Trim(Str(LastRow)))   '出厂日期
    Set MatchCell_InitMoney = ws.Range("BW2:BW" & Trim(Str(LastRow)))   '计税原值
    For iFor = 1 To LastRow - 1
        ZCBUnitName = UCase(Trim(MatchCell_ZCBUnitname(iFor).Value))
        RealUnitName = UCase(Trim(MatchCell_RealUnitname(iFor).Value))
        If ZCBUnitName = STransferOut And RealUnitName = STransferIn Then
            IArrLength = IArrLength + 1
        End If
    Next
    
    ReDim SInfoArr(IArrLength, 6) As String
    IArrCount = 0
    '检索涉及的信息
    For iFor = 1 To LastRow - 1
        ZCBUnitName = UCase(Trim(MatchCell_ZCBUnitname(iFor).Value))
        RealUnitName = UCase(Trim(MatchCell_RealUnitname(iFor).Value))
        If ZCBUnitName = STransferOut And RealUnitName = STransferIn Then
            SAssetCode = UCase(Trim(MatchCell_AssetCode(iFor).Value))       '资产编码
            SAssetName = UCase(Trim(MatchCell_AssetName(iFor).Value))       '资产名称
            RealGGXH = UCase(Trim(MatchCell_RealGGXH(iFor).Value))          '规格型号
            FactoryDate = UCase(Trim(MatchCell_FactoryDate(iFor).Value))    '出厂日期
            MeasureUnit = UCase(Trim(MatchCell_MeasureUnit(iFor).Value))    '计量单位
            InitMoney = UCase(Trim(MatchCell_InitMoney(iFor).Value))        '计税原值
            IArrCount = IArrCount + 1
            SInfoArr(IArrCount, 0) = SAssetCode
            SInfoArr(IArrCount, 1) = SAssetName
            SInfoArr(IArrCount, 2) = RealGGXH
            SInfoArr(IArrCount, 3) = FactoryDate
            SInfoArr(IArrCount, 4) = MeasureUnit
            SInfoArr(IArrCount, 5) = InitMoney
        End If
    Next
    ReadyTransferInfo = SInfoArr
End Function

　　2、生成设备调拨单

Sub GenerateTransferForm(STransferOut As String, STransferIn As String)
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim SSaveFileName As String
    Dim wdTable As Word.Table
    Dim iFor As Integer
    Dim IRowCount As Integer
    Dim tbl As Table
    Dim NewRow As Row
    Dim SDDDate As String
    Dim STransferInfoArr() As String
    Dim TotalAmount As Single
    
    '获取需要生成调拨单的数据记录
    STransferInfoArr = ReadyTransferInfo(STransferOut, STransferIn)
    '打开模板文件写数据
    Set wdApp = New Word.Application
    Set wdDoc = wdApp.Documents.Open("F:\调拨单模板.doc")
    Set tbl = wdDoc.Tables(1)
    wdApp.Visible = False
    SDDDate = Format(Now(), "yyyy年mm月dd日")
    SSaveFileName = "F:\2023年OK\" & STransferOut + "—〉" & STransferIn & ".doc"
    ActiveDocument.Bookmarks("调出单位").Range.Text = STransferOut
    ActiveDocument.Bookmarks("调入单位").Range.Text = STransferIn
    ActiveDocument.Bookmarks("调动日期").Range.Text = SDDDate
    Set wdTable = ActiveDocument.Tables(1)
    IRowCount = 0
    IRowCount = UBound(STransferInfoArr, 1)
    If IRowCount > 12 Then
        For iFor = 1 To IRowCount - 13
            tbl.Rows.Add (tbl.Rows(1).Next)
        Next
    End If
    For iFor = 1 To IRowCount
        TotalAmount = TotalAmount + CCur(STransferInfoArr(iFor, 5))   'CDec、CDbl函数
    Next

    For iFor = 1 To UBound(STransferInfoArr, 1)
        wdTable.Cell(iFor + 1, 1).Range.Text = STransferInfoArr(iFor, 0)
        wdTable.Cell(iFor + 1, 2).Range.Text = STransferInfoArr(iFor, 1)
        wdTable.Cell(iFor + 1, 3).Range.Text = STransferInfoArr(iFor, 2)
        wdTable.Cell(iFor + 1, 4).Range.Text = STransferInfoArr(iFor, 3)
        wdTable.Cell(iFor + 1, 5).Range.Text = STransferInfoArr(iFor, 4)
        wdTable.Cell(iFor + 1, 6).Range.Text = "1"
        wdTable.Cell(iFor + 1, 7).Range.Text = STransferInfoArr(iFor, 5)
        wdTable.Cell(iFor + 1, 8).Range.Text = "生产需要"
    Next iFor
    '填写合计
    If IRowCount > 12 Then
        wdTable.Cell(iFor + 1, 7).Range.Text = Str(TotalAmount)
        wdTable.Cell(iFor + 1, 2).Range.Text = IRowCount
    Else
        wdTable.Cell(14, 7).Range.Text = Str(TotalAmount)
        wdTable.Cell(14, 2).Range.Text = IRowCount
    End If
    
    wdDoc.SaveAs SSaveFileName
    wdDoc.Close
    wdApp.Quit
    'Set wdDoc = noting
    'Set wdApp = noting
End Sub

　　3、循环生成所有的调拨单
　　例如要生成调出单位为信息中心、调入单位为收发室的调拨单，调用函数即可

Call GenerateTransferForm("信息中心", "收发室")

　　4、打印调拨单

Sub printdoc()
    Dim folderPath As String
    Dim wordFile As String
    Dim PrintFileName As String
    
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    
    folderPath = "F:\调拨单\"    
    wordFile = Dir(folderPath & "*.doc")
    
    Set wdApp = New Word.Application
    
    Do While wordFile <> ""
        PrintFileName = folderPath & wordFile
        Debug.Print "OK:" & PrintFileName
        Set wdDoc = wdApp.Documents.Open(PrintFileName)
        Sleep 500
        wdDoc.PrintOut        
        Sleep 500
        wdDoc.Close
        Set wdDoc = Nothing
        Sleep 1000
        ' 处理下一个文件
        wordFile = Dir
    Loop
    wdApp.Quit
    Set wdApp = Nothing    
    MsgBox "打印完毕！"
End Sub

　　VBA还是挺管用的，在日常的工作当中，适当地应用可以替代不少的人工操作，省事又有效率。

　　虽然VBA使用很方便，用过就会有体会，但是要熟练掌握需要了解Word、Excel、PPT的对象模型，同样的操作可以使用的方式方法却多样。

　　VBA很有用，值得用心留意，编程语言很多，对于IT人员而言，编程语言就像是自己的作战工具，对于不同的战斗自然有不同的应对工具。比如有的需要就凭借自身功力，有的可以使用一般的编程工具，大的战斗使用Java和C#，也可以使用一些前端的开发工具等等。

　　VBA需要总结了，方便以后的查找与应用。