Mac下VBA代码.SaveAs保存CSV报错，求跨平台兼容解决方案

老哥，你的代码在Mac上报错主要是两个核心问题：跨平台路径获取不兼容和CSV保存格式的系统差异，另外代码里还有些依赖ActiveWorkbook的不稳定逻辑可以优化。下面一步步给你搞定：

1. 先修复跨平台的路径获取 #

Environ$("USERPROFILE")是Windows独有的环境变量，Mac上得用Environ$("HOME")来拿用户主目录。我们加个系统判断自动适配：

' 替换原有的user_id赋值代码
#If Mac Then
    user_id = Environ$("HOME")
#Else
    user_id = Environ$("USERPROFILE")
#End If

你之前用Application.PathSeparator处理分隔符的思路是对的，这部分不用改，能自动识别Mac的/和Windows的\。

2. 修复CSV保存的兼容性坑 #

Mac版Excel对xlCSV常量的识别有时候会抽风，而且默认的xlCSV在Mac上保存的是Mac格式（LF换行），如果要和Windows兼容，建议指定xlCSVWindows（对应数值23），直接用数值甚至更稳妥。另外，别依赖ActiveWorkbook，直接引用新建的工作簿对象更可靠：

原代码里sh.Move会把新建工作表移到空白工作簿，我们直接抓这个新工作簿的引用：

' 替换原有的Set sh相关代码
Set newWB = Workbooks.Add(xlWBATWorksheet) ' 新建只有一个工作表的工作簿
Set sh = newWB.Sheets(1)

然后修改保存逻辑，区分系统处理：

' 替换原有的保存判断代码
overwrite_question = vbNo
If Dir(Pth) <> "" Then
    overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
End If

If overwrite_question = vbYes Or Dir(Pth) = "" Then
    Application.DisplayAlerts = False
    #If Mac Then
        ' Mac上存成Windows兼容的CSV格式
        newWB.SaveAs Filename:=Pth, FileFormat:=xlCSVWindows
    #Else
        ' Windows用标准CSV格式
        newWB.SaveAs Filename:=Pth, FileFormat:=xlCSV
    #End If
    newWB.Close SaveChanges:=False
    Application.DisplayAlerts = True
End If

3. 顺便优化数据复制的效率 #

你原来逐行循环18000行太慢了，用AutoFilter筛选数据快得多：

' 替换原有的For循环
With Worksheets("Base")
    ' 筛选L列（第12列）前6位是"262015"的行
    .Range("L1").AutoFilter Field:=12, Criteria1:="262015"
    ' 复制D列可见数据到新表的B列
    On Error Resume Next ' 防止没匹配数据时报错
    .Range("D2:D18288").SpecialCells(xlCellTypeVisible).Copy sh.Range("B2")
    On Error GoTo 0
    .AutoFilterMode = False ' 取消筛选
End With

完整修复后的代码 #

Sub Opgave8()
    Dim sh As Worksheet
    Dim user_id As String
    Dim file_name As String
    Dim Pth As String
    Dim overwrite_question As Integer
    Dim newWB As Workbook
    
    Application.ScreenUpdating = False
    
    ' 跨平台获取用户主目录
    #If Mac Then
        user_id = Environ$("HOME")
    #Else
        user_id = Environ$("USERPROFILE")
    #End If
    
    file_name = "AdminExport.csv"
    Pth = user_id & Application.PathSeparator & "Desktop" & Application.PathSeparator & file_name
    
    ' 新建空白工作簿（仅一个工作表）
    Set newWB = Workbooks.Add(xlWBATWorksheet)
    Set sh = newWB.Sheets(1)
    
    ' 用AutoFilter筛选并复制数据，提升效率
    With Worksheets("Base")
        ' 筛选L列（第12列）前6位为"262015"的行
        .Range("L1").AutoFilter Field:=12, Criteria1:="262015", Operator:=xlAnd
        ' 复制D列（第4列）的可见数据到新工作表的B列
        On Error Resume Next ' 防止没有匹配数据时报错
        .Range("D2:D18288").SpecialCells(xlCellTypeVisible).Copy sh.Range("B2")
        On Error GoTo 0
        .AutoFilterMode = False ' 取消筛选
    End With
    
    ' 判断文件是否存在并处理覆盖
    overwrite_question = vbNo
    If Dir(Pth) <> "" Then
        overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
    End If
    
    If overwrite_question = vbYes Or Dir(Pth) = "" Then
        Application.DisplayAlerts = False
        #If Mac Then
            ' Mac上保存为Windows兼容的CSV格式
            newWB.SaveAs Filename:=Pth, FileFormat:=xlCSVWindows
        #Else
            ' Windows上用标准CSV格式
            newWB.SaveAs Filename:=Pth, FileFormat:=xlCSV
        #End If
        newWB.Close SaveChanges:=False
        Application.DisplayAlerts = True
    End If
    
    Application.ScreenUpdating = True
End Sub

Function UniqueRandDigits(x As Long) As String
    Dim i As Long
    Dim n As Integer
    Dim s As String
    Do
        n = Int(Rnd() * 10)
        If InStr(s, n) = 0 Then
            s = s & n
            i = i + 1
        End If
    Loop Until i = x + 1
    UniqueRandDigits = s
End Function

额外小贴士 #

• 如果保存后打开CSV有乱码，可以在SaveAs里加Local:=True参数，用系统本地编码：

  newWB.SaveAs Filename:=Pth, FileFormat:=xlCSVWindows, Local:=True
  

• 确保Mac上的Excel已经启用宏（偏好设置里找安全性选项）

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