|
1、在Thisworkbook里，自定义菜单回调函数，显示用户窗体。 Sub voucherGenerate(control As IRibbonControl) UserForm1.ShowEnd Sub 2、在myModule里，自定义函数与过程： Option Explicit'//字段位置，列号 Public Type pos RQ As Integer PZZ As Integer PZH As Integer ZY As Integer KMDM As Integer '科目代码 KMMC As Integer '科目名称 HBDM As Integer '货币代码 HL As Integer '汇率 JFJE As Integer '借方金额 DFJE As Integer '贷方金额 KHBM As Integer '客户编码 KHMC As Integer '客户名称 BMBM As Integer '部门编码 BMMC As Integer '部门名称End Type
Function fileSelected() With Application.FileDialog(msoFileDialogFilePicker) If .Show = -1 Then fileSelected = .SelectedItems(1) Else Exit Function End If End WithEnd Function
Function getLastDay(currYear As Integer, currMonth As Integer) Dim firstDate As Date firstDate = DateSerial(currYear, currMonth, 1) If firstDate > Date Then firstDate = DateSerial(currYear - 1, currMonth, 1) End If getLastDay = firstDate - 1End Function
Function GetExtn(iName) '//取得文件扩展名 GetExtn = Right(iName, Len(iName) - InStrRev(iName, ".") + 1)End Function
Function ColumnToNumber(column As String) As Long Dim result As Long Dim i As Integer column = UCase(column) result = 0 For i = 1 To Len(column) result = result * 26 + (Asc(Mid(column, i, 1)) - Asc("A") + 1) Next ColumnToNumber = resultEnd Function
Function getMMDD(strName As String) Dim temp Dim i As Integer Dim currMonth As Integer, currDay As Integer strName = Replace(strName, ".", "-") temp = Split(strName, "-") If UBound(temp) = 0 Then getMMDD = strName Else currMonth = temp(0) currDay = temp(1) getMMDD = currMonth & "." & Format(Val(currDay), "00") End IfEnd Function
Sub SortArray(ByRef arr()) Dim temp As Variant Dim i As Long, j As Long For i = LBound(arr) To UBound(arr) For j = i + 1 To UBound(arr) If arr(j) < arr(i) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next NextEnd Sub
Sub changeMonth(dataFile As String, newMonth As Integer) '//这个没用到。 Dim ws As Worksheet Dim i As Integer Dim wb As Workbook Set wb = Workbooks.Open(dataFile) For Each ws In wb.Sheets ws.Name = "t" & Rnd() Next For Each ws In ThisWorkbook.Sheets i = i + 1 ws.Name = newMonth & "-" & i Next wb.Close savechanges:=TrueEnd Sub
3、在UserForm1里，生成凭证导入模板相关代码：Option ExplicitDim dataFile As StringDim FSO As ObjectDim currYear As IntegerDim errMsg As String
Private Sub CmbEnd_Change() If Me.CmbEnd < Me.CmbStart Then Me.CmbStart = Me.CmbEnd End IfEnd Sub
Private Sub CmbStart_Change() If Me.CmbStart > Me.CmbEnd Then Me.CmbEnd = Me.CmbStart End IfEnd Sub
Private Sub CmbYear_Change() currYear = Me.CmbYearEnd Sub
Private Sub CmdChooseFile_Click() Me.TxtDataFile = fileSelected dataFile = Me.TxtDataFileEnd Sub
Private Sub CmdExit_Click() Unload MeEnd Sub
Private Sub CmdGenerate_Click() Dim startDay As String, endDay As String Dim wb As Workbook Dim filePath As String Dim msg As String If Not FSO.fileexists(dataFile) Then MsgBox "文件不存在！" Exit Sub End If currYear = Me.CmbYear startDay = Me.CmbStart endDay = Me.CmbEnd Call generateVoucher(dataFile, currYear, startDay, endDay)
'//凭证导入数据另存为新文件 If Me.CheckBox1 Then filePath = ThisWorkbook.Path & "\导入表_" & Format(Now, "yyyymmddHHnnss") & ".xlsx" Sheet1.Copy Set wb = ActiveWorkbook wb.SaveAs filePath wb.Close End If
If filePath <> "" Then
If errMsg <> "" Then MsgBox "已生成：" & filePath & Chr(10) & errMsg Else MsgBox "已生成：" & filePath
End If Else If errMsg <> "" Then MsgBox "已生成！" & Chr(10) & errMsg Else MsgBox "已生成！" End If End If Unload MeEnd Sub
Private Sub TxtDataFile_Change() Dim fileExtn As String Dim dList As Object, dkey As String Dim wb As Workbook, ws As Worksheet Dim strDate, currMonth, currDay Dim arr() Application.ScreenUpdating = False Set dList = CreateObject("Scripting.Dictionary")
dataFile = Me.TxtDataFile If FSO.fileexists(dataFile) Then fileExtn = GetExtn(dataFile) If fileExtn Like "*.xl*" Then Set wb = Workbooks.Open(dataFile) For Each ws In wb.Sheets dkey = getMMDD(ws.Name) dList(dkey) = "" Next arr = dList.keys Call SortArray(arr)
With Me.CmbStart .List = arr .Text = .List(0) End With
With Me.CmbEnd .List = arr .Text = .List(.ListCount - 1) End With wb.Close savechanges:=False End If End If Application.ScreenUpdating = TrueEnd Sub
Private Sub UserForm_Initialize() Dim arrChar() Dim i As Integer Set FSO = CreateObject("Scripting.FileSystemObject") '//凭证字，可以Array里添加、修改 arrChar = Array("西纺记", "凡高记") With Me.CmbVoucherChar .List = arrChar .Text = .List(0) End With
'//当前年度，添加上年和今年 currYear = Year(Date) With Me.CmbYear .AddItem currYear - 1 .AddItem currYear .Text = .List(.ListCount - 1) End With
'//初始凭证号 With Me.CmbVoucherNumber For i = 1 To 100 .AddItem i Next .Text = .List(0) End With
End Sub
Sub generateVoucher(dataFile As String, currYear As Integer, startDay As String, endDay As String) Dim i As Long, j As Long, k As Integer Dim wb As Workbook, ws As Worksheet Dim firstRow As Integer, lastRow As Integer Dim firstCol As Integer, lastCol As Integer
Dim dic As Object, dicRef As Object, dicCust As Object Dim currMonth As Integer, currDay As Integer Dim key1, key2 Dim arr(), temp(), strDate Dim accCode, accName, currencyName, exchangeRatio, dAmount, cAmount Dim custCode, custName, deptCode, deptName Dim ps As pos Dim fileExtn As String Dim vNumber As Integer Dim currMD As String Dim vChar As String Dim iCol As Integer, totalRow As Long
Dim collectType As String
'On Error Resume Next
iCol = Sheet1.UsedRange.Columns.Count
vNumber = Me.CmbVoucherNumber If vNumber = 0 Then vNumber = 1 End If
vChar = Me.CmbVoucherChar
'//字段位置 With ps .RQ = 1 .PZZ = 2 .PZH = 3 .ZY = 5 .KMDM = ColumnToNumber("F") ' cells(1,"F").column .KMMC = ColumnToNumber("G") .HBDM = ColumnToNumber("K") .HL = ColumnToNumber("M") .JFJE = ColumnToNumber("O") .DFJE = ColumnToNumber("P") .KHBM = ColumnToNumber("Q") .KHMC = ColumnToNumber("R") .BMBM = ColumnToNumber("U") .BMMC = ColumnToNumber("V") End With Set dic = CreateObject("Scripting.dictionary") Set dicRef = CreateObject("Scripting.dictionary") Set dicCust = CreateObject("Scripting.dictionary")
'//对应关系装入字典 Set ws = ThisWorkbook.Sheets("映射关系") arr = ws.UsedRange.Value lastRow = UBound(arr) lastCol = 7 For i = 2 To lastRow For j = 2 To lastCol key1 = arr(i, 1): key2 = arr(1, j) If Not dicRef.exists(key1) Then Set dicRef(key1) = CreateObject("Scripting.Dictionary") End If dicRef(key1)(key2) = arr(i, j) If key2 = "客户名称" Then custCode = arr(i, j - 1) custName = arr(i, j) If custName <> "" Then dicCust(custName) = custCode End If End If Next Next
'//打开工作簿 Set wb = Workbooks.Open(dataFile) totalRow = 0 For Each ws In wb.Sheets key1 = getMMDD(ws.Name) 'mdd If key1 >= startDay And key1 <= endDay Then
If Not dic.exists(key1) Then Set dic(key1) = CreateObject("Scripting.dictionary") End If
lastCol = 8 lastRow = 53 arr = ws.UsedRange.Value For i = 4 To lastRow custName = arr(i, 11) '//备注栏 For j = 3 To lastCol collectType = arr(3, j) If collectType = "挂账" Then collectType = arr(i, 9) If collectType = "担保签字" Then key2 = collectType & ":" & custName & "|" & i Else key2 = collectType & "|" & i End If ElseIf InStr("微信/支付宝", collectType) > 0 Then collectType = "现金" key2 = "现金" ElseIf collectType = "冲订金" Then key2 = collectType & ":" & custName & "|" & i Else key2 = collectType End If dAmount = Val(arr(i, j)) If dAmount <> 0 Then If Not dic(key1).exists(key2) Then totalRow = totalRow + 1 ReDim temp(1 To 1, 1 To iCol) temp(1, ps.ZY) = key1 & "营业额/" & Split(key2, "|")(0) If dicRef.exists(collectType) Then temp(1, ps.KMDM) = dicRef(collectType)("科目代码") temp(1, ps.KMMC) = dicRef(collectType)("科目名称") temp(1, ps.BMBM) = dicRef(collectType)("部门编码") temp(1, ps.BMMC) = dicRef(collectType)("部门名称") Else errMsg = errMsg & key1 & ": 第" & i & "行,导入表第" & totalRow + 3 & "行[" & collectType & "]无映射关系!" & Chr(10)
End If temp(1, ps.HBDM) = "CNY" temp(1, ps.HL) = 1 temp(1, ps.JFJE) = dAmount If collectType = "担保签字" Then temp(1, ps.KHBM) = dicCust(custName) temp(1, ps.KHMC) = custName Else If dicRef.exists(collectType) Then temp(1, ps.KHBM) = dicRef(collectType)("客户编码") temp(1, ps.KHMC) = dicRef(collectType)("客户名称") End If End If
Else temp = dic(key1)(key2) temp(1, ps.JFJE) = temp(1, ps.JFJE) + dAmount End If dic(key1)(key2) = temp End If Next Next totalRow = totalRow + 1 End If Next wb.Close savechanges:=False ReDim arr(1 To totalRow, 1 To iCol) k = 0 For Each key1 In dic.keys If dic(key1).Count > 0 Then k = k + 1 cAmount = 0 strDate = Split(key1, ".") currMonth = strDate(0) currDay = strDate(1) arr(k, ps.RQ) = getLastDay(currYear, currMonth) arr(k, ps.PZZ) = vChar arr(k, ps.PZH) = vNumber For Each key2 In dic(key1).keys temp = dic(key1)(key2) arr(k, ps.ZY) = temp(1, ps.ZY) arr(k, ps.KMDM) = temp(1, ps.KMDM) arr(k, ps.KMMC) = temp(1, ps.KMMC) arr(k, ps.HBDM) = temp(1, ps.HBDM) arr(k, ps.HL) = temp(1, ps.HL) dAmount = temp(1, ps.JFJE) arr(k, ps.JFJE) = dAmount cAmount = cAmount + dAmount arr(k, ps.KHBM) = temp(1, ps.KHBM) arr(k, ps.KHMC) = temp(1, ps.KHMC) arr(k, ps.BMBM) = temp(1, ps.BMBM) arr(k, ps.BMMC) = temp(1, ps.BMMC) k = k + 1 Next arr(k, ps.ZY) = key1 & "营业额" arr(k, ps.KMDM) = dicRef("营业额")("科目代码") arr(k, ps.KMMC) = dicRef("营业额")("科目名称") arr(k, ps.BMBM) = dicRef("营业额")("部门编码") arr(k, ps.BMMC) = dicRef("营业额")("部门名称")
arr(k, ps.DFJE) = cAmount vNumber = vNumber + 1 End If Next
Dim cell As Range With Sheet1 .UsedRange.Offset(3).ClearContents .UsedRange.Columns(1).Offset(3).NumberFormatLocal = "yyyy-mm-dd" .Cells(4, 1).Resize(totalRow, iCol) = arr End WithEnd Sub
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui"> <ribbon> <tabs> <!-- 保留默认功能区选项卡 --> <tab idMso="TabHome" />
<!-- 自定义选项卡 --> <tab id="customTab" label="凭证处理"> <group id="customGroup" label="生成导入文件"> <button id="customButton1" imageMso="PowerQueryGetTransformDataCombine" size="large" onAction="Thisworkbook.voucherGenerate" /> </group> </tab> </tabs> </ribbon></customUI>
|
