如何通过VBA运行PERSONAL.XLSB中的宏实现数据导出至MySQL？及代码有效性排查与问题解决

我来帮你一步步搞定这两个问题——先修复现有代码里的ActiveSheet指向错误，再确保VBScript能正确调用宏并操作目标数据文件。

一、核心问题排查：为什么会导出空白行？ #

你的VBA代码里写了Set ws = ThisWorkbook.ActiveSheet，这里的ThisWorkbook指的是宏所在的PERSONAL.XLSB文件，而不是你打开的目标数据文件。当两个文件同时打开时，PERSONAL.XLSB在前台，宏自然会读取它的空白内容，这就是导出空白行的根源。

二、修正VBA代码：让宏精准操作数据文件 #

我提供两种可靠的修正方案，你可以根据需求选择：

方案1：让宏操作当前激活的数据工作簿 #

如果你的VBScript打开数据文件后能激活它，宏可以直接定位到ActiveWorkbook（当前激活的工作簿）：

Public Sub Insert_Testing()
    Dim con As ADODB.Connection
    Dim lastrow As Long
    Dim ws As Worksheet
    Dim rng As Range
    Dim row As Range
    Dim SQL As String
    
    ' 关键修正：指向当前激活的工作簿（即数据文件），而非PERSONAL.XLSB
    Set ws = ActiveWorkbook.ActiveSheet
    Set con = New ADODB.Connection
    
    ' 注意：去掉Open后面的等号，原代码语法错误
    con.Open "Provider=MSDASQL.1;Data Source=MySQL_db;"
    
    ' 用ws.Rows.Count避免跨工作簿的行数差异问题
    lastrow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
    Set rng = ws.Range("A2:G" & lastrow)
    
    For Each row In rng.Rows
        ' 处理文本字段里的单引号，避免SQL语法错误
        ' 数值类型字段（比如Min_C、Max_C）不要加单引号，否则会触发MySQL类型错误
        SQL = "INSERT INTO skynet_msa.ALU_testing (Area, Min_C, Max_C, Avg_C, Emis, Ta_C, Area_Px) " & _
              "VALUES ('" & Replace(row.Cells(1).Value, "'", "''") & "', " & _
                      row.Cells(2).Value & ", " & _
                      row.Cells(3).Value & ", " & _
                      row.Cells(4).Value & ", " & _
                      "'" & Replace(row.Cells(5).Value, "'", "''") & "', " & _
                      row.Cells(6).Value & ", " & _
                      row.Cells(7).Value & ");"
        con.Execute SQL
    Next row
    
    con.Close
    Set con = Nothing
    MsgBox "数据导出完成！"
End Sub

方案2：让宏接收目标工作簿作为参数（更稳定） #

如果不想依赖工作簿的激活状态，可以让宏直接接收数据工作簿作为参数，避免激活顺序出错：

Public Sub Insert_Testing(ByVal targetWB As Workbook)
    Dim con As ADODB.Connection
    Dim lastrow As Long
    Dim ws As Worksheet
    Dim rng As Range
    Dim row As Range
    Dim SQL As String
    
    ' 直接操作传入的目标工作簿，也可以指定具体工作表（比如targetWB.Worksheets("数据页")）
    Set ws = targetWB.ActiveSheet
    Set con = New ADODB.Connection
    
    con.Open "Provider=MSDASQL.1;Data Source=MySQL_db;"
    
    lastrow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
    Set rng = ws.Range("A2:G" & lastrow)
    
    For Each row In rng.Rows
        SQL = "INSERT INTO skynet_msa.ALU_testing (Area, Min_C, Max_C, Avg_C, Emis, Ta_C, Area_Px) " & _
              "VALUES ('" & Replace(row.Cells(1).Value, "'", "''") & "', " & _
                      row.Cells(2).Value & ", " & _
                      row.Cells(3).Value & ", " & _
                      row.Cells(4).Value & ", " & _
                      "'" & Replace(row.Cells(5).Value, "'", "''") & "', " & _
                      row.Cells(6).Value & ", " & _
                      row.Cells(7).Value & ");"
        con.Execute SQL
    Next row
    
    con.Close
    Set con = Nothing
    MsgBox "数据导出完成！"
End Sub

三、修正VBScript代码：确保正确调用宏 #

你的VBScript里有逻辑错误，导致宏还是会指向PERSONAL.XLSB，这里是修正后的版本：

sPath = "H:\msa\Temp\MengKeat\FlukeReport\20220429\CV4T1L2.11\testing1"
Set oFSO = CreateObject("Scripting.FileSystemObject")
sNewestFile = GetNewestFile(sPath)

If sNewestFile <> "" Then
    WScript.Echo "找到最新文件：" & sNewestFile
    dFileModDate = oFSO.GetFile(sNewestFile).DateLastModified
    ' 只处理24小时内的文件，原代码逻辑缺失执行部分
    If DateDiff("h", dFileModDate, Now) <= 24 Then
        ExcelFilePath = sNewestFile
        MacroPath = "C:\Users\gsumarlin\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB"
        MacroName = "PERSONAL.XLSB!Module1.Insert_Testing"
        
        Set ExcelApp = CreateObject("Excel.Application")
        ExcelApp.Visible = True ' 调试阶段设为True，没问题再改False
        ExcelApp.DisplayAlerts = False
        
        ' 打开数据文件
        Set wb = ExcelApp.Workbooks.Open(ExcelFilePath)
        ' 检查PERSONAL.XLSB是否已打开，避免重复加载
        If Not IsWorkbookOpen(ExcelApp, MacroPath) Then
            Set macWB = ExcelApp.Workbooks.Open(MacroPath)
        End If
        
        ' 方案1：激活数据工作簿，对应方案1的VBA宏
        wb.Activate
        ExcelApp.Run MacroName
        
        ' 方案2：直接传递数据工作簿作为参数，对应方案2的VBA宏
        ' ExcelApp.Run MacroName, wb
        
        wb.Save
        ExcelApp.DisplayAlerts = True
        MsgBox "自动任务已完成，时间：" & TimeValue(Now), vbInformation
        oFSO.DeleteFile sNewestFile
    Else
        WScript.Echo "文件已超过24小时，跳过处理。"
    End If
Else
    WScript.Echo "目标目录为空！"
End If

' 辅助函数：判断指定工作簿是否已打开
Function IsWorkbookOpen(ByVal excelApp, ByVal filePath)
    Dim wb
    IsWorkbookOpen = False
    On Error Resume Next
    Set wb = excelApp.Workbooks.Open(filePath)
    If Err.Number = 0 Then
        IsWorkbookOpen = True
        wb.Close False ' 打开后立即关闭，因为只是验证
    End If
    On Error GoTo 0
End Function

' 修复后的获取最新文件函数
Function GetNewestFile(ByVal sPath)
    Dim sNewestFile, dPrevDate
    Dim oFSO, oFolder, oFiles, oFile
    sNewestFile = "" ' 初始化空值
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(sPath)
    Set oFiles = oFolder.Files
    
    For Each oFile In oFiles
        On Error Resume Next
        If sNewestFile = "" Then
            sNewestFile = oFile.Path
            dPrevDate = oFile.DateLastModified
        ElseIf dPrevDate < oFile.DateLastModified Then
            sNewestFile = oFile.Path
            dPrevDate = oFile.DateLastModified ' 更新最新文件的修改时间
        End If
        On Error GoTo 0
    Next
    
    GetNewestFile = sNewestFile
End Function

VBScript关键修正点： #

• 修复GetNewestFile函数的逻辑，确保正确返回最新文件路径
• 添加IsWorkbookOpen函数，避免重复打开PERSONAL.XLSB
• 打开数据文件后主动激活它（方案1），或者直接传递工作簿参数（方案2）
• 补全了超过24小时文件的处理逻辑

四、额外注意事项 #

1. ODBC数据源验证：确保你配置的MySQL_db数据源能正常连接到目标MySQL数据库，测试一下ODBC连接是否有效
2. 字段类型匹配：确认VBA代码里的字段值类型和MySQL表的字段类型一致，比如数值类型不要加单引号，否则会触发类型错误
3. 错误处理：建议在VBA里添加错误处理逻辑（比如On Error Resume Next或On Error GoTo），方便排查导出过程中的问题
4. PERSONAL.XLSB自动加载：如果PERSONAL.XLSB在Excel启动时会自动加载，VBScript里可以省略手动打开的步骤

内容的提问来源于stack exchange，提问作者Gracella Q Sumarlin