VBA Macro ничего не делает после запуска, не выдает ошибок (macos) - PullRequest
0 голосов
/ 03 июня 2018

Это мой первый вопрос на этой платформе, поэтому, пожалуйста, прости меня за любую ошибку, которую я могу сделать.У меня есть пара книг Excel, в которых я хотел бы внести несколько точных изменений в точные листы и точные ячейки во всех них, но их слишком много, чтобы сделать по отдельности.Я записал все изменения, которые я должен внести в макрос, используя одну из рабочих книг;

Sub Macro1()

Range("W4:X4").Select
ActiveCell.FormulaR1C1 = "OFF -PEAK GEM(MW)"
Range("J33:M33").Select
ActiveCell.FormulaR1C1 = "Hz"
Range("B33:I33").Select
ActiveCell.FormulaR1C1 = "DETAILS"
Range("R34:X34").Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Range("R35:X35").Select
Selection.Cut
Range("R34").Select
ActiveSheet.Paste
Range("K68:L123").Select
Selection.Delete Shift:=xlToLeft
Range("K68:L68").Select
ActiveCell.FormulaR1C1 = "UNITS ON BAR"
Range("V178").Select
ActiveCell.FormulaR1C1 = "EXPECTED RESERVE"
Range("V179:V182").Select

End Sub

Я запустил этот макрос в другой другой неизмененной рабочей книге, и она отлично работала.Я совсем новичок в использовании VBA, но мне удалось найти в сети блок кода, который вносит изменения в несколько файлов Excel в указанном каталоге;

Sub ChangeFiles()
Dim MyPath As String
Dim MyFile As String
Dim dirName As String
Dim wks As Worksheet

' Change directory path as desired
dirName = "c:\myfiles\"

MyPath = dirName & "*.xlsx"
MyFile = Dir(MyPath)
If MyFile > "" Then MyFile = dirName & MyFile

Do While MyFile <> ""
    If Len(MyFile) = 0 Then Exit Do 

    Workbooks.Open MyFile

    With ActiveWorkbook
        For Each wks In .Worksheets
            ' Specify the change to make
            wks.Range("A1").Value = "A1 Changed"
        Next
    End With

    ActiveWorkbook.Close SaveChanges:=True

    MyFile = Dir
    If MyFile > "" Then MyFile = dirName & MyFile
Loop
End Sub 

Я отредактировал его в соответствии со своими потребностями, например:Итак,

Sub ChangeFiles()
Dim MyPath As String
Dim MyFile As String
Dim dirName As String
Dim wks As Worksheet
Set wks = ActiveWorkbook.Worksheets("SHEET X")

' Change directory path as desired
dirName = "/Users/Account/Desktop/Directory 1/Directory 2/"

MyPath = dirName & "*.xls"
MyFile = Dir(MyPath)
If MyFile > "" Then MyFile = dirName & MyFile

Do While MyFile <> ""
    If Len(MyFile) = 0 Then Exit Do

    Workbooks.Open MyFile

    With ActiveWorkbook
        For Each wks In ActiveWorkbook.Worksheets
            ' Specify the change to make
            wks.Range("W4:X4").Select
            ActiveCell.FormulaR1C1 = "OFF -PEAK GEM(MW)"
            wks.Range("J33:M33").Select
            ActiveCell.FormulaR1C1 = "Hz"
            wks.Range("B33:I33").Select
            ActiveCell.FormulaR1C1 = "DETAILS"
            wks.Range("R34:X34").Select
            Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
            wks.Range("R35:X35").Select
            Selection.Cut
            wks.Range("R34").Select
            ActiveSheet.Paste
            wks.Range("K68:L123").Select
            Selection.Delete Shift:=xlToLeft
            wks.Range("K68:L68").Select
            ActiveCell.FormulaR1C1 = "UNITS ON BAR"
            wks.Range("V178").Select
            ActiveCell.FormulaR1C1 = "EXPECTED RESERVE"
            wks.Range("V179:V182").Select
        Next
    End With

    ActiveWorkbook.Close SaveChanges:=True

    MyFile = Dir
    If MyFile > "" Then MyFile = dirName & MyFile
Loop
End Sub

Я запустил его, и он ничего не сделал и не вернул ошибку.Я действительно в своем уме, и я был бы очень признателен за любую помощь.PS Я пользователь Mac

Ответы [ 2 ]

0 голосов
/ 04 июня 2018

Ну, 120 одновременных открытых вкладок (без шуток, я считал ?) и две бессонные ночи спустя я наконец нашел решение. ПРИМЕЧАНИЕ: ЭТО РАБОТАЕТ ТОЛЬКО НА MAC , по-видимому, я думаю Dir не работает на Mac, благодаря @Jeeped за указание на это, поэтому для других пользователей Mac с моей проблемой это то, что я сделал:

Option Explicit
'Important: this Dim line must be at the top of your module
Dim dirName As String

Sub ChangeFiles()
Dim MySplit As Variant
Dim FileIndirName As Long
Dim wks As Worksheet

'Clear dirName to be sure that it not return old info if no files are found
dirName = ""

Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=1, FileFilterOption:=0, FileNameFilterStr:="SearchString")

If dirName <> "" Then
    With Application
        .ScreenUpdating = False
    End With

    MySplit = Split(dirName, Chr(13))
    For FileIndirName = LBound(MySplit) To UBound(MySplit)

    Workbooks.Open (MySplit(FileIndirName))
    Set wks = ActiveWorkbook.Worksheets("SHEET X")

    With wks
       .Range("W4:X4") = "OFF -PEAK GEM(MW)"
        .Range("J33:M33") = "Hz"
        .Range("B33:I33") = "DETAILS"
        .Range("R34:X34").EntireRow.Insert Shift:=xlShiftDown
        .Range("R35:X35").Cut Destination:=Range("R34")
        .Range("K68:L123").Delete Shift:=xlToLeft
        .Range("K68:L68") = "UNITS ON BAR"
        .Range("V178") = "EXPECTED RESERVE"
    End With

    ActiveWorkbook.Close SaveChanges:=True

    Next FileIndirName
        With Application
            .ScreenUpdating = True
        End With
Else
    MsgBox "Sorry no files that match your criteria, A 0 files result can be due to Apple sandboxing: Try using the Browse button to re-select the folder."
    With Application
        .ScreenUpdating = True
    End With
End If
MsgBox "Done!"
End Sub

'*******Function that do all the work that will be called by the macro*********

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
dirName = MacScript(ScriptToRun)
On Error GoTo 0
End Function

Кстати, @urdearboy спасибо за ваше предложение, оно действительно помогло, хотя у меня были проблемы с .PasteSpecial, я все же нашел обходной путь.

Для всех, кому интересноТо, что код делает, когда вы его запускаете, это в основном вызывает диалоговое окно с просьбой выбрать нужную папку, когда вы это делаете, он находит файлы с расширением .xls (вы можете изменить это) и выполняет изменение во всех.xls файлы в этой папке.

Спасибо всем, кто прокомментировал этот пост.^ _ ^

0 голосов
/ 03 июня 2018

Примечание: это не является решением и будет удалено.Просто хотел сделать предложение для OP

Вам нужно обновить свои операции Excel следующим образом.
Эта ссылка покажет вам альтернативы методу .Select.

With wks
    .Range("W4:X4") = "OFF -PEAK GEM(MW)"
    .Range("J33:M33") = "Hz"
    .Range("B33:I33") = "DETAILS"
    .Range("R34:X34").Insert , CopyOrigin:=xlFormatFromLeftOrAbove
    .Range("R35:X35").Copy
    .Range("R35:x35").ClearContents
    .Range("R34").PasteSpecial
    .Range("K68:L123").Delete Shift:=xlToLeft
    .Range("K68:L68") = "UNITS ON BAR"
    .Range("V178") = "EXPECTED RESERVE"
End With
...