如何自动关联未来创建的Excel采购表至实时汇总文件？

一、VBA实现自动检测与关联（含文件存在校验） #

方案1：打开「Real time copy」时批量关联新采购表 #

将以下代码粘贴到「Real time copy.xlsx」的ThisWorkbook模块中，每次打开文件时会自动检测目标文件夹内的新增采购表，完成关联：

Private Sub Workbook_Open()
    Dim purchaseFolder As String
    Dim fileName As String
    Dim wsName As String
    Dim targetWs As Worksheet
    Dim filePath As String
    
    ' 替换为采购表所在的文件夹路径
    purchaseFolder = "C:\你的采购表文件夹路径\"
    
    ' 遍历文件夹中符合命名规则的采购文件
    fileName = Dir(purchaseFolder & "*purchase sheet_*.xlsx")
    
    Do While fileName <> ""
        ' 从文件名提取周数作为工作表名称（假设文件名格式为"purchase sheet_第41周_20241007.xlsx"）
        wsName = Split(Split(fileName, "_")(2), ".")(0) ' 根据实际文件名格式调整拆分逻辑
        
        ' 检查文件是否存在（双重校验，避免Dir缓存问题）
        filePath = purchaseFolder & fileName
        If Dir(filePath) <> "" Then
            ' 检查是否已存在对应工作表
            On Error Resume Next
            Set targetWs = ThisWorkbook.Worksheets(wsName)
            On Error GoTo 0
            
            If targetWs Is Nothing Then
                ' 新增工作表并建立实时链接
                Set targetWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                targetWs.Name = wsName
                
                ' 建立外部数据链接（假设采购表数据在Sheet1的A1开始的区域）
                With targetWs.QueryTables.Add(Connection:="TEXT;" & filePath, Destination:=targetWs.Range("A1"))
                    .Name = "Purchase_" & wsName
                    .FieldNames = True
                    .RowNumbers = False
                    .FillAdjacentFormulas = False
                    .PreserveFormatting = True
                    .RefreshOnFileOpen = True ' 设置为打开文件时自动刷新
                    .RefreshStyle = xlInsertDeleteCells
                    .SavePassword = False
                    .SaveData = True
                    .AdjustColumnWidth = True
                    .RefreshPeriod = 0
                    .TextFilePromptOnRefresh = False
                    .TextFilePlatform = 65001
                    .TextFileStartRow = 1
                    .TextFileParseType = xlDelimited
                    .TextFileTextQualifier = xlTextQualifierDoubleQuote
                    .TextFileConsecutiveDelimiter = False
                    .TextFileTabDelimiter = True
                    .TextFileSemicolonDelimiter = False
                    .TextFileCommaDelimiter = False
                    .TextFileSpaceDelimiter = False
                    .TextFileColumnDataTypes = Array(1, 1, 1) ' 根据实际数据类型调整
                    .TextFileTrailingMinusNumbers = True
                    .Refresh BackgroundQuery:=False
                End With
            Else
                ' 检查现有链接是否有效，无效则重新关联
                Dim qt As QueryTable
                On Error Resume Next
                Set qt = targetWs.QueryTables(1)
                On Error GoTo 0
                
                If Not qt Is Nothing Then
                    If qt.Connection <> "TEXT;" & filePath Then
                        qt.Connection = "TEXT;" & filePath
                        qt.Refresh
                    End If
                End If
            End If
        End If
        
        ' 下一个文件
        fileName = Dir
    Loop
End Sub

方案2：提前创建工作表，文件生成后自动关联 #

如果需要提前创建空白工作表，可在ThisWorkbook中添加以下代码，激活空白表时自动检测对应文件并建立关联：

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Dim purchaseFolder As String
    Dim filePath As String
    
    purchaseFolder = "C:\你的采购表文件夹路径\"
    
    ' 仅处理名称为「第XX周」的工作表
    If Sh.Name Like "第*周" Then
        ' 拼接对应采购文件路径（根据实际命名规则调整）
        filePath = purchaseFolder & "purchase sheet_" & Sh.Name & "_*.xlsx"
        filePath = Dir(filePath) ' 获取第一个匹配的文件名
        
        If filePath <> "" Then
            filePath = purchaseFolder & filePath
            ' 检查是否已有链接，没有则建立
            If Sh.QueryTables.Count = 0 Then
                With Sh.QueryTables.Add(Connection:="TEXT;" & filePath, Destination:=Sh.Range("A1"))
                    ' 配置项同方案1，省略重复代码
                    .Name = "Purchase_" & Sh.Name
                    .RefreshOnFileOpen = True
                    .Refresh BackgroundQuery:=False
                End With
            End If
        End If
    End If
End Sub

二、修复提前设置链接的文件不存在提示问题 #

如果之前手动添加了无效链接，可运行以下代码清理，并确保后续所有关联操作都先做文件存在校验：

Sub CleanInvalidLinks()
    Dim qt As QueryTable
    Dim ws As Worksheet
    
    For Each ws In ThisWorkbook.Worksheets
        For Each qt In ws.QueryTables
            ' 提取链接中的文件路径
            Dim filePath As String
            filePath = Mid(qt.Connection, 6) ' 去掉开头的"TEXT;"
            
            If Dir(filePath) = "" Then
                qt.Delete ' 删除无效链接
            End If
        Next qt
    Next ws
End Sub

三、Access数据库是否更简便？ #

视场景而定：

• 适合用Access的情况：如果采购数据量较大、需要频繁做跨表统计/查询，或多人协同编辑，Access更高效。它可以直接将整个文件夹的Excel文件作为外部表导入，内置查询能一键合并所有采购数据，还能设置自动刷新，无需复杂VBA即可避免无效链接提示。
• 继续用Excel的情况：如果只是简单的实时同步、日常操作更习惯Excel界面，Excel+VBA的方案完全足够，学习成本更低。

内容的提问来源于stack exchange，提问作者Konstantins Zabogonskis