【原】「代碼」VBA案例，跟我一起學做工資條

冷茶視界 2025-03-19 發布于江蘇

展開全文

點【關于本公眾號】了解一下，歡迎關注，謝謝！

快速瀏覽

實用案例

|日期控件 ||簡單的收發存||
收費管理系(Access改進版)|

|電子發票管理助手||電子發票登記系統(Access版)|

|文件合并 ||表格拆分||審計憑證抽查底稿|

|中醫診所收費系統(Excel版)||中醫診所收費系統(Access版)||銀行對賬單自動勾對|

|印章使用登記系統|

收費使用項目

|財務管理系統||工資薪金和年終獎個稅籌劃||新稅法下工資表模版|

內容提要

工資條|完整代碼

1、在工作表“工資表”里，命令按鈕點擊事件，調用生成過程。

Private Sub CmdGenerate_Click()    Call generatePayslipEnd Sub

2、在myModule里，自定義過程generatePayslip，生成工資條：

Sub generatePayslip()    Dim rngTemplate As Range    Dim ws As Worksheet    Dim arr(), temp()    Dim i As Integer, j As Integer, k As Integer    Dim firstRow As Integer, lastRow As Integer    Dim lastCol As Integer    Dim keyWord As String    Set ws = ThisWorkbook.Sheets("工資表")    firstRow = 2    With ws        lastRow = .UsedRange.Rows.Count        lastCol = .UsedRange.Columns.Count        arr = .Range(.Cells(firstRow, 1), .Cells(lastRow, lastCol)).Value    End With    Set rngTemplate = ThisWorkbook.Sheets("模板").Range("A1:AA3")    temp = rngTemplate.Rows(1).Value    temp = Application.Transpose(temp)    lastRow = UBound(temp)    For i = 2 To UBound(arr)        If arr(i, 1) = "總計" Then Exit For        k = (i - 1) * 3        ReDim Preserve temp(1 To lastRow, 1 To k)        For j = 1 To lastRow            keyWord = temp(j, 1)            If k > 3 Then                temp(j, k - 2) = keyWord            End If            temp(j, k - 1) = arr(i, Pxy(arr, keyWord, 2))        Next    Next    Set ws = ThisWorkbook.Sheets("工資條")    With ws        .Cells.Clear        For i = 1 To k Step 3            rngTemplate.Copy Destination:=.Cells(i, 1)        Next'        For i = 1 To rngTemplate.Columns.Count'            .Columns(i).columnWidth = rngTemplate.Columns(i).columnWidth'        Next        .Cells(1, 1).Resize(k, lastRow) = Application.Transpose(temp)    End With    MsgBox "完成！"    ws.ActivateEnd Sub

3、在myModule里，自定義函數Pxy，數組字段定位：

Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0)    '**********************************    '//參數說明：    '//arr(),數組，可以是一維也可以是二維    '//FieldName，字段名，需要定位的字段名    '//arrType=0,表示一維數組    '//arrType=1,表示二維數組，查找第一列    '//arrType=2,表示二維數組，查找第一行    '**********************************    Dim k As Integer, t As Integer, i As Integer    k = 0: t = 0    Select Case arrType    Case Is = 0        '//一維數組，循環數組，查找字段值,取得其位置k        '//如果找到，則令t=1,退出循環        For i = LBound(arr) To UBound(arr)            k = k + 1            If arr(i) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 1        '//二維數組，循環數組，在第一列查找字段值,取得其位置k        '//如果找到，則令t=1,退出循環        For i = LBound(arr, 1) To UBound(arr, 1)            k = k + 1            If arr(i, 1) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 2        '//二維數組，循環數組，在第一行查找字段值,取得其位置k        '//如果找到，則令t=1,退出循環        For i = LBound(arr, 2) To UBound(arr, 2)            k = k + 1            If arr(1, i) = FieldName Then                t = 1                Exit For            End If        Next    End Select    '//如果t=1,表示找到了字段的值，函數的值等于k    '//否則，表示沒找到字段的值，函數的值等0    If t = 1 Then        Pxy = k    Else        Pxy = 0    End IfEnd Function