问题： 我有一个 Excel VBA 宏，可以在 Mac 上完美运行，但是当我尝试在 PC 上运行它时，它无法按预期运行。该宏旨在将多个 Excel 文件中的数据合并到一个工作簿中，但是，当我尝试在我的 PC 上运行该宏时，它所做的只是打开一个新文件，其中第一个单元格 (A1) 上带有“Ready”一词。
以下是该宏的功能摘要：
初始化变量和设置。
使用
GetFilesOnMacWithOrWithoutSubfolders处理获取的列表中的每个文件，打开它，检查第三个工作表中的特定数据，然后将其复制到新工作簿中。
清理并恢复初始设置。
在 PC 上运行宏时会出现此问题。代码的某些部分，例如 AppleScript 命令 (
MacScript这是我的问题：
如何修改宏使其同时兼容Mac和PC平台？
重写代码时我应该注意哪些特定于 Windows 的命令或注意事项？
如何处理Mac和PC环境下Excel版本的差异以确保兼容性？
任何有关如何解决此问题的指导或建议将不胜感激。谢谢！
代码片段：
Option Explicit
'Important: this Dim line must be at the top of your module
Public MyFiles As String
Function GetFilesOnMacWithOrWithoutSubfolders(Level As Long, ExtChoice As Long, _
FileFilterOption As Long, FileNameFilterStr As String)
'Ron de Bruin,Version 4.0: 27 Sept 2015
'http://www.rondebruin.nl/mac.htm
'Thanks to DJ Bazzie Wazzie and Nigel Garvey(posters on MacScripter)
Dim ScriptToRun As String
Dim folderPath As String
Dim FileNameFilter As String
Dim Extensions As String
On Error Resume Next
folderPath = MacScript("choose folder as string")
If folderPath = "" Then Exit Function
On Error GoTo 0
Select Case ExtChoice
Case 0: Extensions = "(xls|xlsx|xlsm|xlsb)" 'xls, xlsx , xlsm, xlsb
Case 1: Extensions = "xls" 'Only xls
Case 2: Extensions = "xlsx" 'Only xlsx
Case 3: Extensions = "xlsm" 'Only xlsm
Case 4: Extensions = "xlsb" 'Only xlsb
Case 5: Extensions = "csv" 'Only csv
Case 6: Extensions = "txt" 'Only txt
Case 7: Extensions = ".*" 'All files with extension, use *.* for everything
Case 8: Extensions = "(xlsx|xlsm|xlsb)" 'xlsx, xlsm , xlsb
Case 9: Extensions = "(csv|txt)" 'csv and txt files
'You can add more filter options if you want,
End Select
Select Case FileFilterOption
Case 0: FileNameFilter = "'.*/[^~][^/]*\\." & Extensions & "$' " 'No Filter
Case 1: FileNameFilter = "'.*/" & FileNameFilterStr & "[^~][^/]*\\." & Extensions & "$' " 'Begins with
Case 2: FileNameFilter = "'.*/[^~][^/]*" & FileNameFilterStr & "\\." & Extensions & "$' " ' Ends With
Case 3: FileNameFilter = "'.*/([^~][^/]*" & FileNameFilterStr & "[^/]*|" & FileNameFilterStr & "[^/]*)\\." & Extensions & "$' " 'Contains
End Select
folderPath = MacScript("tell text 1 thru -2 of " & Chr(34) & folderPath & _
Chr(34) & " to return quoted form of it's POSIX Path")
folderPath = Replace(folderPath, "'\''", "'\\''")
If Val(Application.Version) < 15 Then
ScriptToRun = ScriptToRun & "set foundPaths to paragraphs of (do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """)" & Chr(13)
ScriptToRun = ScriptToRun & "repeat with thisPath in foundPaths" & Chr(13)
ScriptToRun = ScriptToRun & "set thisPath's contents to (POSIX file thisPath) as text" & Chr(13)
ScriptToRun = ScriptToRun & "end repeat" & Chr(13)
ScriptToRun = ScriptToRun & "set astid to AppleScript's text item delimiters" & Chr(13)
ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to return" & Chr(13)
ScriptToRun = ScriptToRun & "set foundPaths to foundPaths as text" & Chr(13)
ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to astid" & Chr(13)
ScriptToRun = ScriptToRun & "foundPaths"
Else
ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """ "
End If
On Error Resume Next
MyFiles = MacScript(ScriptToRun)
On Error GoTo 0
End Function
Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
'Case 1 = last row
'Case 2 = last column
'Case 3 = last cell
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
----------------------------------------------------------------------------------------------------
Option Explicit
Sub MergeCode1()
Dim BaseWks As Worksheet
Dim rnum As Long
Dim CalcMode As Long
Dim MySplit As Variant
Dim FileInMyFiles As Long
Dim Mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim SourceRcount As Long
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
BaseWks.Range("A1").Font.Size = 36
BaseWks.Range("A1").Value = "Please Wait"
rnum = 1
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Clear MyFiles to be sure that it not return old info if no files are found
MyFiles = ""
'Get the files, set the level of folders and extension in the code line below
Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="")
'Level : 1= Only the files in the folder you select, 2 to ? levels of subfolders
'ExtChoice : 0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3
' Work with the files if MyFiles is not empty.
If MyFiles <> "" Then
MySplit = Split(MyFiles, Chr(13))
For FileInMyFiles = LBound(MySplit) To UBound(MySplit)
Set Mybook = Nothing
On Error Resume Next
Set Mybook = Workbooks.Open(MySplit(FileInMyFiles))
On Error GoTo 0
If Not Mybook Is Nothing Then
On Error Resume Next
With Mybook.Worksheets(3)
Set sourceRange = .Range("O10:AK1208")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
Mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MySplit(FileInMyFiles)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
Mybook.Close savechanges:=False
End If
Next FileInMyFiles
BaseWks.Columns.AutoFit
End If
ExitTheSub:
BaseWks.Range("A1").Value = "Ready"
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
如上所述，您可以使用条件编译。
在模块中添加以下内容：
Public MyFiles As String
'use conditional compilation to ensure Mac/Win compatibility
#If Mac Then
'place code for `GetFilesOnMacWithOrWithoutSubfolders` here
#End If
#If Win32 Then
'PC equivalent of `GetFilesOnMacWithOrWithoutSubfolders` (as used
' in the posted use case)
Sub GetFilesOnPC(filePattern As String)
Dim folder As String, f As String, res As String
'ask the user to select a folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select source folder"
If .Show = True Then
If .SelectedItems.Count > 0 Then
folder = .SelectedItems(1)
End If
End If
End With
If Len(folder) = 0 Then Exit Sub 'no folder selected
'check for file matches
f = Dir(folder & "\" & filePattern, vbNormal)
Do While Len(f) > 0
res = res & IIf(Len(res) > 0, vbCr, "") & f
f = Dir() 'next file
Loop
MyFiles = res
End Sub
#End If
然后在你的主代码中：
MyFiles = ""
#If Mac Then
'Get the files, set the level of folders and extension in the code line below
Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="")
'Level : 1= Only the files in the folder you select, 2 to ? levels of subfolders
'ExtChoice : 0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3
#End If
#If Win32 Then
GetFilesOnPC "*.xls*"
#End If