多未打开XLSX工作簿数据合并、ActiveX选项按钮取值及日期格式设置

需求明确 #

• 提取每个源工作簿指定区域的数据，写入主工作簿的单行中
• 读取源工作簿内带链接单元格的ActiveX选项按钮标题，仅复制选中状态的按钮标题到目标单元格
• 在目标单元格添加yyyy/mm/dd格式的日期值

现有测试代码问题分析 #

你提供的测试代码通过WshShell执行命令行获取文件列表，再用外部引用公式提取数据，但存在以下问题：

• 命令行参数拼接错误（dir命令格式不正确）
• 未实现ActiveX选项按钮的读取逻辑
• 缺少日期添加功能
• 外部引用公式会依赖源文件路径，后续文件移动会导致数据失效

优化后的完整VBA代码 #

Sub BatchProcessWorkbooks()
    Dim sourcePath As String
    Dim fileNames As Variant
    Dim targetWs As Worksheet
    Dim sourceWb As Workbook
    Dim sourceWs As Worksheet
    Dim i As Long, j As Long
    Dim dateCell As Range
    Dim optBtn As OLEObject
    
    ' 配置主工作簿目标工作表
    Set targetWs = ThisWorkbook.Worksheets("主工作表") ' 替换为你的目标工作表名称
    ' 配置源文件存放路径
    sourcePath = ThisWorkbook.Path & "\Book1\" ' 修正路径格式，确保末尾有斜杠
    
    ' 获取路径下所有XLSX文件
    fileNames = GetFileList(sourcePath & "*.xlsx")
    If IsEmpty(fileNames) Then
        MsgBox "未找到任何XLSX文件", vbExclamation
        Exit Sub
    End If
    
    ' 从第4行开始写入数据（与原代码保持一致）
    i = 4
    For j = LBound(fileNames) To UBound(fileNames)
        ' 写入源文件名
        targetWs.Cells(i, 2).Value = fileNames(j)
        
        ' 后台静默打开源工作簿（只读模式，不更新链接）
        Set sourceWb = Workbooks.Open(sourcePath & fileNames(j), ReadOnly:=True, UpdateLinks:=False)
        Set sourceWs = sourceWb.Worksheets("sheet1") ' 替换为源文件的工作表名称
        
        ' 1. 复制指定区域数据（示例为F1和C4，可按需修改单元格地址）
        targetWs.Cells(i, 3).Value = sourceWs.Range("F1").Value
        targetWs.Cells(i, 4).Value = sourceWs.Range("C4").Value
        
        ' 2. 读取选中的ActiveX选项按钮标题
        For Each optBtn In sourceWs.OLEObjects
            If TypeName(optBtn.Object) = "OptionButton" Then
                ' 检查按钮是否链接单元格且处于选中状态
                If optBtn.LinkedCell <> "" And optBtn.Object.Value = True Then
                    targetWs.Cells(i, 5).Value = optBtn.Object.Caption ' 写入第5列，可调整目标列
                    Exit For ' 假设每个工作簿仅一个选中选项，需多个则移除该行
                End If
            End If
        Next optBtn
        
        ' 3. 添加yyyy/mm/dd格式的当前日期
        Set dateCell = targetWs.Cells(i, 6)
        dateCell.Value = Date
        dateCell.NumberFormat = "yyyy/mm/dd"
        
        ' 关闭源工作簿，不保存任何修改
        sourceWb.Close SaveChanges:=False
        i = i + 1
    Next j
    
    MsgBox "数据批量处理完成", vbInformation
End Sub

' 辅助函数：获取指定路径下的目标文件列表
Function GetFileList(filePath As String) As Variant
    Dim fileArr() As String
    Dim file As String
    Dim count As Long
    
    file = Dir(filePath)
    If file = "" Then
        GetFileList = Empty
        Exit Function
    End If
    
    count = 0
    Do While file <> ""
        count = count + 1
        ReDim Preserve fileArr(1 To count)
        fileArr(count) = file
        file = Dir()
    Loop
    
    GetFileList = fileArr
End Function

代码关键说明 #

1. 文件获取：用GetFileList替代命令行，避免系统环境差异导致的命令执行失败
2. 源文件处理：以只读模式静默打开，避免弹窗干扰，处理后立即关闭释放资源
3. 选项按钮读取：遍历工作表内所有ActiveX控件，精准筛选符合条件的选中按钮
4. 日期设置：直接写入当前日期并格式化，无需依赖公式
5. 数据稳定性：直接复制单元格值，而非创建外部引用，避免源文件移动导致的数据失效

使用注意事项 #

• 替换代码中的"主工作表"为你实际的目标工作表名称
• 确认源工作簿的工作表名称为"sheet1"，否则修改对应代码行
• 如需处理多个选中的选项按钮，移除Exit For并调整目标单元格列号

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