如何停止导致 VBA 无限循环的只读文件？

Question

这里的新手，通常会通过反复试验找到自己的方式，但在这里遇到困难。

我有一个循环遍历文件夹中的文件并将每个文件中的数据复制到主文件中。

由于每个文件都是工作文档，因此其他用户可能会打开其中一个文件，因此我试图在文件为只读时否定它。

我尝试了一个文件计数器，但不确定我是否掌握了它！

Sub Pull_Decisions()

Dim x As Workbook, y As Workbook
Dim folderPath As String, path As String
Dim StartTime As Double, SecondsElapsed As Double
Dim fileCounter As Integer

'Remember time when macro starts
StartTime = Timer



'Removes filters to allow all data to be shown and reduce risk of overwriting data
On Error Resume Next
ActiveSheet.ShowAllData

'message to prompt user to check filter
filterCheck = MsgBox("Please check all filters are cleared before proceeding. Do you want to proceed?", vbYesNo)

Application.Visible = False 'Hides Excel whilst Macro Running
'Application.Visible = True


If filterCheck = vbYes Then

    Application.ScreenUpdating = False
    'Set this workbook as x workbooks
    Set x = ThisWorkbook

    x.Worksheets(1).range("K5").Value = Format(Now(), "dd/mm/yyyy hh:mm:ss") 'Update refresh time
    If x.ReadOnly Then
                Application.ScreenUpdating = True
                y.Close 'close master workbook
                MsgBox "Decision Submissions spreadsheet is in read only mode and cannot refresh. Please reopen in write mode to refresh table."
                Application.Visible = True
                'Determine how many seconds code took to run
                SecondsElapsed = Round(Timer - StartTime, 2)

                'Notify user in seconds
                MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
                Exit Sub
    End If

'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 = "PATH TO REQUIRED 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 = "*.xlsm*"

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

Set y = ThisWorkbook
Set ws2 = y.Sheets("Allsubmissions")

'Loop through each Excel file in folder
Do While myFile <> "" Or fileCounter = 50
    fileCounter = fileCounter + 1
    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)
    If wb.ReadOnly Then 'If someone is in the workbook, the file will open as read only.
            Application.ScreenUpdating = True
            wb.Close
            'MsgBox " Workbook is currently in use, please try again shortly"
    Else
    'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
    With wb.Sheets("Decisions")
      lRow = .range("A" & Rows.Count).End(xlUp).Row
      .range("A2:I2" & lRow).Copy ws2.range("A" & Rows.Count).End(xlUp)(2)
      .range("A2:I2" & lRow).Delete
    End With

    wb.Close SaveChanges:=True
    'Get next file name
    myFile = Dir
End If
Loop

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

Else
    'If person wants to abort the refresh to clear the filter (shouldn't be required due to above code)
    MsgBox "refresh aborted"

    Application.Visible = True
    'Determine how many seconds code took to run
    SecondsElapsed = Round(Timer - StartTime, 2)
    'Notify user in seconds
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
    Exit Sub
End If

Application.Visible = True 'Makes excel visible again

'Determine how many seconds code took to run and notifies user
  SecondsElapsed = Round(Timer - StartTime, 2)
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
  
y.Save

End Sub

理想情况下，我还希望预先定义文件夹而不使用“FldrPicker”，但是当我尝试这样做时，代码会运行但没有任何副本。

抱歉，这篇文章太长了，如果有任何帮助，我们将不胜感激！

Answer 1

Option Explicit

Sub Pull_Decisions()

    Const FOLDER = "C:\temp\so\70786709\"
    Const EXT = "*.xlsm*"
    Const LIMIT = 50 ' max files

    Dim wbMaster As Workbook, wb As Workbook
    Dim wsAll As Worksheet
    Dim filecount As Long, lastrow As Long, total As Long
    Dim myfile As String, ro As String, msg As String
    Dim t0 As Single: t0 = Timer

    Set wbMaster = ThisWorkbook
    If wbMaster.ReadOnly Then
        MsgBox "This workbook is in read only mode and cannot refresh. " & vbLf & _
                "Please reopen in write mode to refresh table.", vbCritical, "Read Only"
        wbMaster.Close
        Exit Sub
    End If
    
    ' prepare sheet
    Set wsAll = wbMaster.Sheets("Allsubmissions")
    wsAll.AutoFilterMode = False ' remove autofilter
    wsAll.Range("K5").Value = Format(Now(), "dd/mm/yyyy hh:mm:ss")
   
    ' scan files in folder
    myfile = Dir(FOLDER & EXT)
    Application.ScreenUpdating = False
    Do While myfile <> ""
        filecount = filecount + 1
        If filecount > LIMIT Then
            MsgBox "File count > " & LIMIT, vbCritical
            Exit Sub
        End If
    
        Set wb = Workbooks.Open(Filename:=FOLDER & myfile)
        'If someone is in the workbook, the file will open as read only.
        If wb.ReadOnly Then
            ro = ro & vbLf & myfile ' store for later
            wb.Close
        Else
                
            'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook ???
            With wb.Sheets("Decisions")
                lastrow = .Range("A" & .Rows.count).End(xlUp).Row
                If lastrow > 1 Then
                     total = total + lastrow - 1
                    .Range("A2:I" & lastrow).Copy wsAll.Range("A" & Rows.count).End(xlUp).Offset(1)
                    .Range("A2:I" & lastrow).Delete
                    wb.Close SaveChanges:=True
                Else
                    wb.Close SaveChanges:=False
                End If
            End With
        End If
        'Get next file name
        myfile = Dir

    Loop
    Application.ScreenUpdating = True
    
    ' result
    msg = total & " lines from " & filecount & " files." & vbLf
    If Len(ro) > 0 Then
        MsgBox msg & "These files were readonly; " & ro & vbLf & "Try again later.", vbExclamation, "Total = " & total
    Else
        MsgBox msg, vbInformation, Format(Timer - t0, "0.0 secs")
    End If
    
End Sub