又在《电脑编程技巧与维护》上发表了一篇论文，刊登在2013年第23期上

基于EXCEL VBA+ACCESS的工资查询系统设计与实现

文章在这里

最后附上代码

http://s15/mw690/001lK57Ygy6JcoQFdBcae&690VBA+ACCESS实现工资查询" TITLE="又发表了一篇关于EXCEL的论文——EXCEL VBA+ACCESS实现工资查询" />

http://s13/mw690/001lK57Ygy6GJDKYtju8c&690VBA+ACCESS实现工资查询" TITLE="又发表了一篇关于EXCEL的论文——EXCEL VBA+ACCESS实现工资查询" />

http://s16/mw690/001lK57Ygy6GJDLoO5Nbf&690VBA+ACCESS实现工资查询" TITLE="又发表了一篇关于EXCEL的论文——EXCEL VBA+ACCESS实现工资查询" />

http://s16/mw690/001lK57Ygy6GJDLQ2yr0f&690VBA+ACCESS实现工资查询" TITLE="又发表了一篇关于EXCEL的论文——EXCEL VBA+ACCESS实现工资查询" />

http://s8/mw690/001lK57Ygy6GJDMcwE737&690VBA+ACCESS实现工资查询" TITLE="又发表了一篇关于EXCEL的论文——EXCEL VBA+ACCESS实现工资查询" />

Option Explicit
Dim mydb As DAO.Database
Dim mytbl As DAO.TableDef
Dim rs As DAO.Recordset
Sub create()
    Dim mydata$, mytable$
    mydata = ThisWorkbook.Path & "\wagechange.mdb"
    If Dir(mydata) <> "" Then Kill mydata
    Set mydb = CreateDatabase(mydata, dbLangChineseSimplified)
    mytable = "工资变动数据库"
    Set mytbl = mydb.CreateTableDef(mytable)
    With mytbl
        .Fields.Append .CreateField("姓名", dbText, 10)
        .Fields.Append .CreateField("拼音代码", dbText, 10)
        .Fields.Append .CreateField("变动原因", dbText, 20)
        .Fields.Append .CreateField("统计序号", dbInteger)
        .Fields.Append .CreateField("岗位工资", dbInteger)
        .Fields.Append .CreateField("薪级", dbInteger)
        .Fields.Append .CreateField("薪级工资", dbInteger)
        .Fields.Append .CreateField("见习工资", dbInteger)
        .Fields.Append .CreateField("职务津贴", dbInteger)
        .Fields.Append .CreateField("物价补贴", dbDouble)
        .Fields.Append .CreateField("其他津补贴", dbDouble)
        .Fields.Append .CreateField("执行时间", dbText, 6)
    End With
    mydb.TableDefs.Append mytbl
    mydb.Close
    Set mydb = Nothing
    Set mytbl = Nothing
    MsgBox "操作完成"
End Sub

Function pinyin(hanzi)
    Dim i%
    Dim tmp As Long
    Dim char$, getpychar$, OK$
    For i = 1 To Len(hanzi)
        char = Mid(hanzi, i, 1)
        tmp = 65536 + Asc(char)
        If (tmp >= 45217 And tmp <= 45252) Then getpychar = "A"
        If (tmp >= 45253 And tmp <= 45760) Then getpychar = "B"
        If (tmp >= 45761 And tmp <= 46317) Then getpychar = "C"
        If (tmp >= 46318 And tmp <= 46825) Then getpychar = "D"
        If (tmp >= 46826 And tmp <= 47009) Then getpychar = "E"
        If (tmp >= 47010 And tmp <= 47296) Then getpychar = "F"
        If (tmp >= 47297 And tmp <= 47613) Then getpychar = "G"
        If (tmp >= 47614 And tmp <= 48118) Then getpychar = "H"
        If (tmp >= 48119 And tmp <= 49061) Then getpychar = "J"
        If (tmp >= 49062 And tmp <= 49323) Then getpychar = "K"
        If (tmp >= 49324 And tmp <= 49895) Then getpychar = "L"
        If (tmp >= 49896 And tmp <= 50370) Then getpychar = "M"
        If (tmp >= 50371 And tmp <= 50613) Then getpychar = "N"
        If (tmp >= 50614 And tmp <= 50621) Then getpychar = "O"
        If (tmp >= 50622 And tmp <= 50905) Then getpychar = "P"
        If (tmp >= 50906 And tmp <= 51386) Then getpychar = "Q"
        If (tmp >= 51387 And tmp <= 51445) Then getpychar = "R"
        If (tmp >= 51446 And tmp <= 52217) Then getpychar = "S"
        If (tmp >= 52218 And tmp <= 52697) Then getpychar = "T"
        If (tmp >= 52698 And tmp <= 52979) Then getpychar = "W"
        If (tmp >= 52980 And tmp <= 53688) Then getpychar = "X"
        If (tmp >= 53689 And tmp <= 54480) Then getpychar = "Y"
        If (tmp >= 54481 And tmp <= 62289) Then getpychar = "Z"
        If char = "泓" Then getpychar = "H"
        If char = "翟" Then getpychar = "Z"
        If char = "闫" Then getpychar = "Y"
        If char = "钰" Then getpychar = "Y"
        If char = "佘" Then getpychar = "S"
        If char = "晖" Then getpychar = "H"
        If char = "葭" Then getpychar = "J"
        If char = "芸" Then getpychar = "Y"
        If char = "窦" Then getpychar = "D"
        If char = "岐" Then getpychar = "Q"
        If char = "喆" Then getpychar = "Z"
        If char = "薇" Then getpychar = "W"
        If char = "茜" Then getpychar = "Q"
        If char = "娅" Then getpychar = "Y"
        If char = "笃" Then getpychar = "D"
        If char = "瑜" Then getpychar = "Y"
        If char = "皓" Then getpychar = "H"
        If char = "蔺" Then getpychar = "L"
        If char = "缑" Then getpychar = "G"
        If char = "芙" Then getpychar = "F"
        If char = "邸" Then getpychar = "D"
        If char = "解" Then getpychar = "X"
        If char = "璘" Then getpychar = "L"
        If char = "媛" Then getpychar = "Y"
        If char = "婷" Then getpychar = "T"
        If char = "璟" Then getpychar = "J"
        If char = "昱" Then getpychar = "Y"
        If char = "楠" Then getpychar = "N"
        If char = "婕" Then getpychar = "J"
        If char = "岚" Then getpychar = "L"
        If char = "桦" Then getpychar = "H"
        If char = "鑫" Then getpychar = "X"
        If char = "韬" Then getpychar = "T"
        If char = "倩" Then getpychar = "Q"
        If char = "瑾" Then getpychar = "J"
        If char = "(" Then getpychar = "("
        If char = ")" Then getpychar = ")"
        OK = OK + getpychar
    Next i
    pinyin = OK
End Function

Option Explicit
Dim mydb As DAO.Database
Dim mytbl As DAO.TableDef
Dim rs As DAO.Recordset
Private Sub CommandButton1_Click()
    TextBox1.SetFocus
    TextBox1.SelStart = 0
    TextBox1.SelLength = Len(TextBox1)
End Sub
Private Sub CommandButton2_Click()
    UserForm2.Show
End Sub
Private Sub CommandButton3_Click()
    Unload Me
    ThisWorkbook.Close savechanges:=False
End Sub

Private Sub CommandButton4_Click()
    If CommandButton4.Caption = "高级" Then
        If InputBox("请输入密码", "aa", "a") = "12dd540" Then
            Me.Height = 420
            CommandButton4.Caption = "常规"
        End If
    Else
        CommandButton4.Caption = "高级"
        Me.Height = 340
    End If
End Sub

Private Sub CommandButton5_Click()
    Dim i%
    Dim filename As Variant
    Dim mybook As Workbook
    Dim mysheet As Worksheet
    filename = Application.GetOpenFilename(("Excel文件 (*.xls), *.xls"), , "请选择要导入的文件")
    If filename = False Then Exit Sub
    Set mybook = Workbooks.Open(filename, , True)
    Set mysheet = mybook.Worksheets("事改2")
    Set rs = mydb.OpenRecordset("工资变动数据库", dbOpenDynaset)
    With rs
        For i = 7 To 1249
            .AddNew
            .Fields("姓名") = mysheet.Cells(i, 2)
            .Fields("拼音代码") = pinyin(mysheet.Cells(i, 2))
            .Fields("变动原因") = "2006年7月工资改革"
            .Fields("统计序号") = mysheet.Cells(i, 41)
            .Fields("岗位工资") = IIf(mysheet.Cells(i, 28) = "", 0, mysheet.Cells(i, 28))
            .Fields("薪级") = IIf(mysheet.Cells(i, 29) = "", 0, mysheet.Cells(i, 29))
            .Fields("薪级工资") = IIf(mysheet.Cells(i, 30) = "", 0, mysheet.Cells(i, 30))
            .Fields("见习工资") = IIf(mysheet.Cells(i, 31) = "", 0, mysheet.Cells(i, 31))
            .Fields("职务津贴") = ThisWorkbook.Sheets("职务津贴").Cells(mysheet.Cells(i, 41), 1)
            .Fields("物价补贴") = IIf(mysheet.Cells(i, 3) = "男", 49.5, IIf(mysheet.Cells(i, 41) <= 26, 57.5, 55.5))
            .Fields("其他津补贴") = 0
            .Fields("执行时间") = "200607"
            .Update
        Next i
    End With
    mybook.Close savechanges:=False
    MsgBox "成功导入"
End Sub
Private Sub CommandButton6_Click()
    Dim i%, j%
    Dim yuanyin As Variant
    Dim filename As Variant
    Dim mybook As Workbook
    Dim mysheet As Worksheet
    filename = Application.GetOpenFilename(("Excel文件 (*.xls), *.xls"), , "请选择要导入的文件", , True)
    If Not IsArray(filename) Then Exit Sub
    For j = 1 To UBound(filename)
        Set mybook = Workbooks.Open(filename(j), , True)
        Set mysheet = mybook.Worksheets("事变2")
        yuanyin = mybook.Worksheets("事变").Range("G2")
        Set rs = mydb.OpenRecordset("工资变动数据库", dbOpenDynaset)
        With rs
            For i = 7 To mysheet.Range("B65536").End(xlUp).Row
                .AddNew
                .Fields("姓名") = mysheet.Cells(i, 2)
                .Fields("拼音代码") = pinyin(mysheet.Cells(i, 2))
                .Fields("变动原因") = yuanyin
                .Fields("统计序号") = mysheet.Cells(i, 33)
                .Fields("岗位工资") = IIf(mysheet.Cells(i, 24) = "", 0, mysheet.Cells(i, 24))
                .Fields("薪级") = IIf(mysheet.Cells(i, 25) = "", 0, mysheet.Cells(i, 25))
                .Fields("薪级工资") = IIf(mysheet.Cells(i, 26) = "", 0, mysheet.Cells(i, 26))
                .Fields("见习工资") = IIf(mysheet.Cells(i, 27) = "", 0, mysheet.Cells(i, 27))
                If CInt(Left(mysheet.Cells(i, 30), 4)) < 2011 Then
                    .Fields("职务津贴") = ThisWorkbook.Sheets("职务津贴").Cells(mysheet.Cells(i, 33), 1)
                    .Fields("物价补贴") = IIf(mysheet.Cells(i, 3) = "男", 49.5, IIf(mysheet.Cells(i, 33) <= 26, 57.5, 55.5))
                    .Fields("其他津补贴") = 0
                Else
                    .Fields("职务津贴") = 0
                    .Fields("物价补贴") = 0
                    If mysheet.Cells(i, 33) = 26 Then
                        If CLng(mysheet.Cells(i, 30)) < 201110 Then
                            .Fields("其他津补贴") = IIf(mysheet.Cells(i, 8) = "本科", 1220, 1120)
                        Else
                            .Fields("其他津补贴") = IIf(mysheet.Cells(i, 8) = "本科", 1310, 1190)
                        End If
                    Else
                        If CLng(mysheet.Cells(i, 30)) < 201110 Then
                            .Fields("其他津补贴") = ThisWorkbook.Sheets("基础绩效").Cells(mysheet.Cells(i, 33), 1)
                        Else
                            .Fields("其他津补贴") = ThisWorkbook.Sheets("基础绩效").Cells(mysheet.Cells(i, 33), 2)
                        End If
                    End If
                End If
                .Fields("执行时间") = mysheet.Cells(i, 30)
                .Update
            Next i
        End With
        mybook.Close savechanges:=False
    Next j
    MsgBox "成功导入"
End Sub
Private Sub ListBox1_Click()
    Dim sql$, xm$
    Dim mydata()
    Dim mycount%, i%
    Dim gz1 As Double, gz2 As Double
    Dim myquery As DAO.QueryDef
    Laxm.Caption = ListBox1.Value
    xm = ListBox1.Value
    Laxm2.Caption = ""
    ListBox2.Clear
    For Each myquery In mydb.QueryDefs
        If myquery.Name = "人员查询" Then mydb.QueryDefs.Delete "人员查询"
    Next
    sql = "select * from 工资变动数据库 where 姓名='" & xm & "' order by 执行时间"
    Set myquery = mydb.CreateQueryDef("人员查询", sql)
    Set rs = myquery.OpenRecordset
    ReDim mydata(1 To rs.RecordCount, 1 To 11)
    mycount = 0
    Do While Not rs.EOF
        mydata(mycount + 1, 1) = rs.Fields("变动原因")
        mydata(mycount + 1, 2) = rs.Fields("统计序号")
        mydata(mycount + 1, 3) = rs.Fields("岗位工资")
        mydata(mycount + 1, 4) = rs.Fields("薪级")
        mydata(mycount + 1, 5) = rs.Fields("薪级工资")
        mydata(mycount + 1, 6) = rs.Fields("见习工资")
        mydata(mycount + 1, 7) = rs.Fields("职务津贴")
        mydata(mycount + 1, 8) = rs.Fields("物价补贴")
        mydata(mycount + 1, 9) = rs.Fields("其他津补贴")
        mydata(mycount + 1, 10) = rs.Fields("执行时间")
        rs.MoveNext
        mycount = mycount + 1
    Loop
    For i = LBound(mydata) To UBound(mydata) - 1
        gz1 = mydata(i, 3) + mydata(i, 5) + mydata(i, 6) + mydata(i, 7) + mydata(i, 8) + mydata(i, 9)
        gz2 = mydata(i + 1, 3) + mydata(i + 1, 5) + mydata(i + 1, 6) + mydata(i + 1, 7) + mydata(i + 1, 8) + mydata(i + 1, 9)
        mydata(i + 1, 11) = gz2 - gz1
    Next i
    ListBox2.List = mydata
    Lalistno.Caption = ListBox2.ListCount
    If ListBox2.ListIndex = -1 Then
        Lagwjb.Caption = ""
        Ladagz.Caption = ""
    End If
End Sub
Private Sub ListBox2_Click()
    Dim xh$
    Dim myrow%
    Laxm2.Caption = ListBox1.Value
    myrow = ListBox2.ListIndex
    xh = ListBox2.List(myrow, 1)
    Lagwjb.Caption = Application.WorksheetFunction.VLookup(CInt(xh), ThisWorkbook.Sheets("use").Range("A1:B24"), 2, 0)
    With ListBox2
        Ladagz.Caption = CInt(.List(myrow, 2)) + CInt(.List(myrow, 4)) + CInt(.List(myrow, 5)) + CInt(.List(myrow, 6)) + CSng(.List(myrow, 7)) + CInt(.List(myrow, 8))
    End With
End Sub
Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Set myie = CreateObject("InternetExplorer.Application")
    myie.Navigate ("E:\工资\历次工资增长方案")
    myie.Visible = True
End Sub
Private Sub TextBox1_Change()
    Dim sql$
    Dim chaxun$
    Dim myquery As DAO.QueryDef
    TextBox1.Text = UCase(TextBox1.Text)
    ListBox1.Clear
    If TextBox1.Text = "" Then
        Lajs = 0
        Exit Sub
    End If
    If Right(TextBox1.Text, 1) = "0" Then
        chaxun = "'" & Left(TextBox1.Text, Len(TextBox1.Text) - 1) & "'"
    Else
        chaxun = "'" & TextBox1.Text & "*'"
    End If
    For Each myquery In mydb.QueryDefs
        If myquery.Name = "拼音查询" Then mydb.QueryDefs.Delete "拼音查询"
    Next
    sql = "select distinct 姓名 from 工资变动数据库 where 拼音代码 like " & chaxun
    Set myquery = mydb.CreateQueryDef("拼音查询", sql)
    Set rs = myquery.OpenRecordset
    Do While Not rs.EOF
        ListBox1.AddItem rs.Fields("姓名")
        rs.MoveNext
    Loop
    Lajs.Caption = ListBox1.ListCount
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyDown Then
        If ListBox1.ListCount > 0 Then
            ListBox1.SetFocus
            ListBox1.ListIndex = 0
        End If
    End If
End Sub
Private Sub UserForm_Initialize()
    ListBox2.ColumnWidths = "110,25,35,25,35,35,30,40,40,50,45"
    Dim mytable$, mydata$
    mydata = ThisWorkbook.Path & "\wagechange.mdb"
    If Dir(mydata) = "" Then
        MsgBox "数据库不存在", vbCritical, "错误"
        Exit Sub
    End If
    Set mydb = OpenDatabase(mydata, True, False)
    mytable = "工资变动数据库"
    Set mytbl = mydb.TableDefs(mytable)
    Me.Height = 340
End Sub
Private Sub UserForm_Terminate()
    mydb.Close
    Set mydb = Nothing
End Sub