AutoBOM/VBA/Modules/AccessDataModule.bas

'=====================================================================
' 模块名: AccessDataModule
' 功能: 连接Access数据库，根据[总排号]提取数据并填充到[产品订单]工作表
'=====================================================================

Option Explicit

'=====================================================================
' 配置区域 (请根据你的实际情况修改以下常量)
'=====================================================================
' Access数据库文件的完整路径
Private Const DB_PATH = "\\192.168.110.114\生产进度表\2025年数据\生产合同数据.accdb"
' Access中目标数据表的名称
Private Const TARGET_TABLE = "26年压力表合同数据"

'=====================================================================
' 过程: FetchDataFromAccess
' 功能: 主控程序，执行数据提取和回填逻辑
'=====================================================================
Public Sub FetchDataFromAccess()
    On Error GoTo ErrorHandler

    Dim startTime As Double
    startTime = Timer

    Dim ws As Worksheet
    Set ws = GetOrderSheet()
    If ws Is Nothing Then
        MsgBox "未找到[产品订单]工作表，请检查工作表名称。", vbCritical
        Exit Sub
    End If

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).row

    If lastRow < 2 Then
        MsgBox "[产品订单]工作表中没有需要处理的数据。", vbInformation
        Exit Sub
    End If

    ' 1. 将Excel数据读入内存数组 (A到F列)
    Dim dataArr As Variant
    dataArr = ws.Range("A2:F" & lastRow).value

    ' 收集所有的总排号，用于构建SQL查询条件
    Dim queueNums As String
    Dim i As Long
    Dim currentNum As String

    For i = 1 To UBound(dataArr, 1)
        currentNum = Trim(dataArr(i, 1))
        If currentNum <> "" Then
            ' 假设总排号是文本类型。如果是纯数字类型，请去掉单引号
            queueNums = queueNums & "'" & currentNum & "',"
        End If
    Next i

    If queueNums = "" Then
        MsgBox "没有找到有效的总排号。", vbInformation
        Exit Sub
    End If

    ' 去除最后一个逗号
    queueNums = Left(queueNums, Len(queueNums) - 1)

    ' 2. 连接Access数据库并查询
    Dim cn As Object
    Dim rs As Object
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    ' 构建连接字符串 (适用于 .accdb 格式)
    Dim connStr As String
    connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_PATH & ";"

    cn.Open connStr

    ' 构建SQL语句，只提取需要的字段和匹配的总排号
    Dim sql As String
    sql = "SELECT 总排号, 生产订单号, 产品型号, 数量, 成品物料码 " & _
          "FROM [" & TARGET_TABLE & "] " & _
          "WHERE 总排号 IN (" & queueNums & ")"

    rs.Open sql, cn, 1, 1 ' adOpenKeyset, adLockReadOnly

    ' 3. 将查询结果存入字典，利用字典的哈希特性实现极速匹配
    Dim dbDict As Object
    Set dbDict = CreateObject("Scripting.Dictionary")

    If Not rs.EOF Then
        rs.MoveFirst
        Do Until rs.EOF
            Dim key As String
            key = Trim(rs.Fields("总排号").value)

            ' 将需要的字段打包成一个数组存入字典
            If Not dbDict.Exists(key) Then
                dbDict.Add key, Array( _
                    rs.Fields("生产订单号").value, _
                    rs.Fields("产品型号").value, _
                    rs.Fields("数量").value, _
                    rs.Fields("成品物料码").value _
                )
            End If
            rs.MoveNext
        Loop
    End If

    ' 关闭数据库连接
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing

    ' 4. 将字典中的数据回填到内存数组
    Dim matchCount As Long
    matchCount = 0

    For i = 1 To UBound(dataArr, 1)
        currentNum = Trim(dataArr(i, 1))
        If dbDict.Exists(currentNum) Then
            Dim dbRecord As Variant
            dbRecord = dbDict(currentNum)

            ' 将对应的字段映射到数组的相应列
            dataArr(i, 2) = dbRecord(0) ' B列: 生产订单号
            dataArr(i, 3) = dbRecord(1) ' C列: 产品型号
            dataArr(i, 4) = dbRecord(2) ' D列: 数量
            dataArr(i, 5) = dbRecord(3) ' E列: 产品编码 (成品物料码)
            ' F列 (部件优先) 保持原样，不作修改

            matchCount = matchCount + 1
        End If
    Next i

    ' 5. 将更新后的数组一次性写回工作表
    ws.Range("A2:F" & lastRow).value = dataArr

    ' 清理内存
    Set dbDict = Nothing

    Dim elapsedTime As Double
    elapsedTime = Timer - startTime

    MsgBox "数据提取完成!" & vbCrLf & _
           "成功匹配并更新了 " & matchCount & " 条记录。" & vbCrLf & _
           "用时: " & Format(elapsedTime, "0.00") & " 秒", vbInformation

    Exit Sub

ErrorHandler:
    ' 确保发生错误时关闭数据库连接
    On Error Resume Next
    If Not rs Is Nothing Then
        If rs.State = 1 Then rs.Close
    End If
    If Not cn Is Nothing Then
        If cn.State = 1 Then cn.Close
    End If
    On Error GoTo 0

    MsgBox "提取Access数据时发生异常: " & Err.Description, vbCritical
End Sub

'=====================================================================
' 函数: GetOrderSheet
' 功能: 获取[产品订单]工作表
' 返回: Worksheet - 工作表对象
'=====================================================================
Private Function GetOrderSheet() As Worksheet
    On Error Resume Next
    Set GetOrderSheet = ThisWorkbook.Worksheets("产品订单")
    On Error GoTo 0
End Function