保存文件時繞過「檢查兼容性」

Question

我收到了一個循環遍歷目錄並執行計算的宏。 當我運行我的宏我不得不手動檢查兼容性， 有沒有辦法可以跳過整個檢查兼容性？它有點挫敗了這種自動化的目的。

Sub final() 
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 
'This Loops trough all files, does calc, then closes them. But right now I have to check compatibility for each file. 


Dim wb As Workbook 
Dim myPath As String 
Dim myFile As String 
Dim myExtension As String 
Dim FldrPicker As FileDialog 

'Optimize Macro Speed 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
    Application.Calculation = xlCalculationManual 

'Retrieve Target Folder Path From User 
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

    With FldrPicker 
     .Title = "Select A Target Folder" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then GoTo NextCode 
     myPath = .SelectedItems(1) & "\" 
    End With 

'In Case of Cancel 
NextCode: 
    myPath = myPath 
    If myPath = "" Then GoTo ResetSettings 

'Target File Extension (must include wildcard "*") 
    myExtension = "*.xls" 

'Target Path with Ending Extention 
    myFile = Dir(myPath & myExtension) 

'Loop through each Excel file in folder 
    Do While myFile <> "" 
    'Set variable equal to opened workbook 
     Set wb = Workbooks.Open(Filename:=myPath & myFile) 




    Dim xrng As Range, lrw As Long, lrng As Range, i As Long 
    Dim LstCo As Long, ws As Worksheet 


    With Application 
     .ScreenUpdating = False 
     .Calculation = xlCalculationManual 
    End With 

    For Each ws In ActiveWorkbook.Worksheets 
     With ws 

      If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then 

       LstCo = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column 
       For i = 1 To LstCo 
        With .Columns(i) 
         .TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True 
        End With 
       Next 

       lrw = .Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).Row 
       If lrw = 1 Then lrw = 2 
       Set lrng = .Range("A" & lrw + 2) 

       With .Range("A2:A" & lrw) 
        lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")" 
       End With 


       Set xrng = .Range(lrng, .Cells(lrng.Row, LstCo)) 


       lrng.AutoFill xrng, Type:=xlFillDefault 
       xrng.Style = "Percent" 
      End If 
     End With 
    Next 

    With Application 
     .ScreenUpdating = True 
     .Calculation = xlCalculationAutomatic 
     Application.CalculateFull 
    End With 





    'Save and Close Workbook 
     wb.Close SaveChanges:=True 

    'Get next file name 
     myFile = Dir 
    Loop 

'Message Box when tasks are completed 
    MsgBox "Task Complete!" 

ResetSettings: 
    'Reset Macro Optimization Settings 
    Application.EnableEvents = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 

End Sub 

Answer 1

保存文件之前添加行wb.CheckCompatibility = False - 文檔here