Как прописать в макросе на VBA для файлов Excel, чтобы пропускать диалоговые сообщения "Файл уже используется"
Формулировка задачи:
Добрый день. Помогите пожалуйста, есть следующая проблема. В коде есть цикл, который открывает все файлы экселевские в папке на редактирование, также с этими файлами иногда могут работать еще одни пользователи, в моменты когда они заняли файл на редактирование, чтобы цикл не останавливался, а шел дальше, то есть системно прописать на системное сообщение Excel "Файл уже используется...", чтобы выбиралось "отмена", либо чтобы данное окно игнорировалось и цикл шел дальше. Только начинаю изучать и писать на VBA, опыта очень мало, помогите пожалуйста (ниже код цикла
Решение задачи: «Как прописать в макросе на VBA для файлов Excel, чтобы пропускать диалоговые сообщения "Файл уже используется"»
textual
Листинг программы
Function IsOpen(File$) As Boolean
Dim FN%
FN = FreeFile
On Error Resume Next
Open File For Random Access Read Write Lock Read Write As #FN
Close #FN
IsOpen = Err
End Function
Sub Test()
Debug.Print IsOpen("....xlsx")
End Sub
Sub Get_All_File_from1()
'убрать окно с ПредупреждениеОКонфиденциальнойИнформации
ActiveWorkbook.RemovePersonalInformation = 0
If ActiveWorkbook.RemovePersonalInformation Then
ActiveWorkbook.RemovePersonalInformation = False
End If
'Отключаем обновление экрана, чтобы наши действия не мелькали
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Dim sFolder As String, sFiles As String, m As Range, s As Integer, i As Integer, wbReturn As Workbook, rFiles As String
' Адрес папки, где все файлы сотрудников
sFolder = "..."
sFiles = Dir(sFolder & "*.xlsx")
rFiles = sFolder & sFiles
Do While sFiles <> ""
If IsOpen(rFiles) = False Then
'открываем книги сотрудников
Workbooks.Open sFolder & sFiles
n = ActiveWorkbook.Name
'действия с файлом
ActiveWorkbook.Sheets(1).Select
If Not IsEmpty(Range("A2")) Then
FinalRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
FinalColumn = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Sheets(1).Range(Sheets(1).Cells(2, 1), Sheets(1).Cells(FinalRow, FinalColumn)).Copy
'Активация книги "..."
Workbooks("....xlsm").Worksheets("...").Activate
'Определение следующей пустой строки в файле "..."
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
Rows(NextRow).Select
ActiveSheet.Paste
' Активация листа"
Worksheets("...").Activate
'Определение следующей пустой строки в файле "..."
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
Rows(NextRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Переход к активной книге сотрудников и удаление добавленных строк
Workbooks(n).Activate
ActiveWorkbook.Sheets(1).Select
Sheets(1).Range(Sheets(1).Cells(2, 1), Sheets(1).Cells(FinalRow, FinalColumn)).Select
Selection.Delete
'Закрытие файлов сотрудников и сохранение
ActiveWorkbook.Save
ActiveWorkbook.Close
Else: ActiveWorkbook.Close
End If
End If
sFiles = Dir
Loop
' Удаление записей по меткам
Workbooks("....xlsm").Worksheets("...").Activate
i = 1
Do While Cells(i, 1) <> Empty
If (Cells(i, 9).Value) Like "*новое время*" Or (Cells(i, 9).Value) Like "*последний перезвон*" Then
' MsgBox Cells(i, 1).Value
If (Cells(i, 9).Value) Like "*новое время*" Then a1 = Cells(i, 1).Value
If (Cells(i, 9).Value) Like "*последний перезвон*" Then a2 = Cells(i, 1).Value
End If
b = 1
Do While Cells(b, 1) <> Empty
If (Cells(b, 1).Value) = a1 And Not (Cells(b, 9).Value) Like "*новое время*" And Not (Cells(b, 9).Value) Like "*последний перезвон*" Then
Rows(b).Delete
b = b - 1
End If
If (Cells(b, 1).Value) = a2 Then
Rows(b).Delete
b = b - 1
End If
b = b + 1
Loop
i = i + 1
Loop
'
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Workbooks("....xlsm").Close True 'Если поставить False - книга будет закрыта без сохранения
End Sub