很早以前就写了一个以ACCESS为后台数据库、以EXCEL的VBA查询程序为前台的查询工资演变的程序。今天放在博客里做个备份，以供查询。

 http://s8/mw690/49c182c2h7b9d7d838bc7&690

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 As Range) As String
    Dim i%
    Dim tmp$
    For i = 1 To Len(hanzi)
        If Asc(Mid(hanzi, i, 1)) <= 126 And Asc(Mid(hanzi, i, 1)) >= 33 Then  ' 126为"~"   33为"!"
            tmp = Mid(hanzi, i, 1)
        Else
            tmp = Application.WorksheetFunction.VLookup(Mid(hanzi, i, 1), [{"吖","A";"八","B";"嚓","C";"咑","D";"鵽","E";"发","F";"猤","G";"铪","H";"夻","J";"咔","K";"垃","L";"嘸","M";"旀","N";"噢","O";"妑","P";"七","Q";"囕","R";"仨","S";"他","T";"屲","W";"夕","X";"丫","Y";"帀","Z"}], 2)
        End If
        pinyin = pinyin + tmp
    Next i
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