AutoBOM/VBA/Modules/AccessDataModule.bas

'=====================================================================
' 模块名: AccessDataModule
' 功能: 连接Access数据库，根据[总排号]提取数据并填充到[产品订单]工作表
' 特性: [安全极速版] 完美解决筛选状态下全量数组写回导致的错位 Bug
'=====================================================================

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. 获取A列中所有筛选后的（可见）单元格
    Dim visibleRange As Range
    On Error Resume Next
    Set visibleRange = ws.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible)
    On Error GoTo ErrorHandler

    If visibleRange Is Nothing Then
        MsgBox "当前筛选状态下没有可见的数据。", vbInformation
        Exit Sub
    End If

    ' 2. 仅收集可见行中的总排号
    Dim cell As Range
    Dim queueNums As String
    Dim currentNum As String

    For Each cell In visibleRange
        currentNum = Trim(cell.value)
        If currentNum <> "" Then
            queueNums = queueNums & "'" & currentNum & "',"
        End If
    Next cell

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

    queueNums = Left(queueNums, Len(queueNums) - 1)

    ' 3. 连接Access查询并装入字典 (内存极速匹配)
    Dim cn As Object, rs As Object
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    Dim connStr As String
    connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_PATH & ";"
    cn.Open connStr

    Dim sql As String
    sql = "SELECT 总排号, 生产订单号, 产品型号, 数量, 成品物料码 " & _
          "FROM [" & TARGET_TABLE & "] " & _
          "WHERE 总排号 IN (" & queueNums & ")"

    rs.Open sql, cn, 1, 1

    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

    ' 关闭屏幕刷新、自动计算和事件触发，拉满单行写入性能
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    For Each cell In visibleRange
        currentNum = Trim(cell.value)

        If dbDict.Exists(currentNum) Then
            Dim dbRecord As Variant
            dbRecord = dbDict(currentNum)

            ' 【神级优化点】：将4个字段装入一个微型一维数组，利用 Resize 一次性写入 B 到 E 列
            ' 这样每一行只需要 1 次单元格操作，而不是 4 次！性能无限逼近全量数组写回。
            cell.Offset(0, 1).Resize(1, 4).value = Array(dbRecord(0), dbRecord(1), dbRecord(2), dbRecord(3))

            matchCount = matchCount + 1
        End If
    Next cell

    ' 恢复应用状态
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Set dbDict = Nothing

    Dim elapsedTime As Double
    elapsedTime = Timer - startTime

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

    Exit Sub

ErrorHandler:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    On Error Resume Next
    If Not rs Is Nothing Then If rs.State = 1 Then rs.Close
    If Not cn Is Nothing Then If cn.State = 1 Then cn.Close
    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