关键词：Access数据库 、 VBA窗体、 ADO

工作要求：将定额库中的数据自动输入对应行的目标单元格内

Excel中 VBA 窗体 配合数据库 完成数据自动录入

工作中，经常性需要参照工具书录入对应数据，此方法可以高效率解决数据录入问题，提升效率。

思路：

将大量数据导入access数据库中，在excel的VBA中通过ADO调取数据；（若数据存储于excel表中则影响软件运行效率，尤其参杂公式后效率更低）制作查询窗体，在对应表格内做好逻辑处理，即双击单元格调取窗体后选择数据双击自动录入，单元格自动下移，继续双击窗体内符合条件的数据直至结束。

窗体代码：

Option Explicit

Dim con As ADODB.Connection

Dim rs As ADODB.Recordset

Private Sub lstBM_Click()

Dim sql As String '定义命令字符串变量

sql = "select 定额编号,子目名称,定额计量,定额单位,主材内容,主材系数,人工费,工日消耗,辅材费,机械费 from 定额库update where 定额册NO='" & lstBM.Value & "' order by ID"

rs.Open sql, con, adOpenKeyset, adLockOptimistic

'数组转置

Dim arr As Variant, arr1 As Variant, i%, j%

arr = rs.GetRows

ReDim arr1(1 To UBound(arr, 2) 1, 0 To UBound(arr, 1))

'For i = 1 To UBound(arr, 2) 1

' For j = 0 To UBound(arr, 1)

' arr1(i, j) = arr(j, i - 1)

' Next

'Next

'MsgBox rs.Fields.Count

With Me.ListBox1

.Clear

.ColumnCount = rs.Fields.Count

.ColumnHeads = False

.RowSource = ""

.BackColor = &HFFFF00

.ColumnWidths = "40 磅;400 磅;40 磅;40 磅;40 磅;40 磅;40 磅;40 磅;40 磅"

For i = 1 To UBound(arr, 2) 1

For j = 0 To UBound(arr, 1)

arr1(i, j) = arr(j, i - 1)

Next

Next

' .TextAlign = fmTextAlignCenter

.List = arr1

End With

rs.Close

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Dim cs As Long

Dim X, y, sh

Set sh = ActiveSheet

X = ActiveCell.Row

y = ActiveCell.Column

cs = ListBox1.ListIndex

' MsgBox cs

If X <= 5 And cs < 0 Then Exit Sub ' =0 时是第一行 现在第一行选中不能执行 需要 删除 =

Cells(X, "J") = CStr(ListBox1.List(cs, 0)) '定额编号

Cells(X, "K") = CStr(ListBox1.List(cs, 2)) '定额单位

Cells(X, "L") = CStr(ListBox1.List(cs, 3)) '定额计量

Cells(X, "N") = CStr(ListBox1.List(cs, 5)) '主材系数

Cells(X, "O") = CStr(ListBox1.List(cs, 6)) '人工费

Cells(X, "P") = CStr(ListBox1.List(cs, 7)) '工日消耗

Cells(X, "Q") = CStr(ListBox1.List(cs, 8)) '辅材费

Cells(X, "R") = CStr(ListBox1.List(cs, 9)) '机械费

ActiveCell.Offset(1, 0).Select

End Sub

Private Sub UserForm_Initialize()

Set con = New ADODB.Connection

With con

.Provider = "microsoft.ace.oledb.12.0"

.ConnectionString = ThisWorkbook.Path & "机电定额组价库.accdb"

.Open

End With

Dim sql As String '定义命令字符串变量

'sql = "select distinct 定额册NO from 定额库 order by ID" 此写法冲突

sql = "select 定额册NO from 定额库update group by 定额册NO order by max(ID)" '解决Sql中DIstinct与Order By共同使用的冲突问题

Set rs = New ADODB.Recordset '创建记录集对象

rs.Open sql, con, adOpenKeyset, adLockOptimistic

'将记录集中的部门名称显示到lstBM列表框中

Dim i%

With lstBM

.Clear

For i = 1 To rs.RecordCount

.AddItem rs("定额册NO")

rs.MoveNext '将记录集中的指针指向下一条记录

Next i

End With

rs.Close

End Sub

表内代码：

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim r As Long

r = Target.Row

With Target

If .Row > 5 Then

If .Column <> 13 And .Column > 9 And .Column < 18 Then

Cancel = True

UserForm1.Show

End If

End If

End With

End Sub

演示如下：

想获取源码的小伙伴可以保持联系～

扫码进娱乐群