Как прописать в макросе на 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

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

12   голосов , оценка 3.833 из 5
Похожие ответы