Страницы: 1
RSS
Предупреждение о том, что книга уже открыта, макрос
 
Есть книга  "Работа" с макросом, при запуске макроса открывается книга "Отбор" (тоже с макросами), в книге "Отбор" удаляются данные, на их место из книги "Работа" вставляются новые данные.

Но, если книга "Отбор" открыта другим пользователем, то через макрос книга "Отбор" открывается в режиме чтения (без каких либо предупреждений и всплывающих окон) - в дальнейшем все идет не по плану, старая информация не удаляется, новая не сохраняется....

Нужен макрос (часть макроса) которая будет останавливать текущий процесс, при этом должно появиться всплывающее окно - "Книга открыта пользователем "........" , нажмите "да", чтобы продолжить".

я увижу что книга открыта, и кем она открыта, попрошу пользователя закрыть книгу, нажму "да" и процесс продолжится

Код
Sub aaa()

  Application.ScreenUpdating = False  'отключаем обновление экрана для скорости

  Workbooks.Open Filename:="\\s\Files_server\Отдел\_ОБЩАЯ\С\Отбор.xlsm" 'открыть книгу
    Workbooks("Отбор.xlsm").Windows(1).WindowState = xlMaximized 'на первый план
      Workbooks("Отбор.xlsm").Activate 'на первый план

  Sheets("ОП").Select 'выбрать лист
    Call Application.Run("'Отбор.xlsm'!Модуль.Очистка") 'запустить макрос
      Excel.ActiveWorkbook.Save 'сохранить книгу
        ActiveWorkbook.Close True 'закрыть книгу без подтверждения

  Sheets("Доп").Select 'выбрать лист
    Range("B4").Select 'выбрать ячейку
      Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
        Selection.Copy 'копировать
          Sheets("Отбор").Select 'выбрать лист
            Range("A2").Select 'выбрать ячейку
              Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                   :=False, Transpose:=False 'вставить только значения
     
  Sheets("Доп").Select 'выбрать лист
    Range("CA4").Select 'выбрать ячейку
      Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
        Selection.Copy 'копировать
          Sheets("Отбор").Select 'выбрать лист
            Range("B2").Select 'выбрать ячейку
              Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                   :=False, Transpose:=False 'вставить только значения
                   
  Sheets("Авто").Select 'выбрать лист
    Range("BZ4").Select 'выбрать ячейку
      Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
        Selection.Copy 'копировать
          Sheets("Отбор").Select 'выбрать лист
            Range("C2").Select 'выбрать ячейку
              Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                   :=False, Transpose:=False 'вставить только значения

  Range("A2:C2").Select 'выбрать диапазон
    Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
      Selection.Copy 'копировать

  Workbooks.Open Filename:="\\s\Files_server\Отдел\_ОБЩАЯ\С\Отбор.xlsm" 'открыть книгу
    Workbooks("Отбор.xlsm").Windows(1).WindowState = xlMaximized 'на первый план
      Workbooks("Отбор.xlsm").Activate 'на первый план

  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False 'вставить только значения
    Range("A2").Select 'выбрать ячейку
  
  Excel.ActiveWorkbook.Save 'сохранить книгу
  
    If Weekday(Date, 2) = 1 Then 'если сегодня понедельник
      Dim x As String
        strPath = "\\s\Files_server\Отдел\_ОБЩАЯ\С\Архив\Отбор"     'папка для сохранения резервной копии
      On Error Resume Next
        x = GetAttr(strPath) And 0
          If Err = 0 Then ' если путь существует - сохраняем копию книги, добавляя дату-время
            strDate = Format(Now, "dd.mm.yy hh.mm") 'формат сегодняшней даты и времени
              FileNameXls = strPath & "\" & "Отбор" & " " & strDate & ".xlsm" 'название и формат сохраняемого файла
                ActiveWorkbook.SaveCopyAs Filename:=FileNameXls 'сохранить объединив условия
          Else 'если путь не существует - выводим сообщение
            MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical 'сообщение в случае ошибки
          End If 'конец блока если
     End If 'конец блока если
     
  ActiveWorkbook.Close True 'закрыть книгу без подтверждения
    Application.ScreenUpdating = True 'включаем обновление экрана
End Sub 'конец
 
mitya528, можно попробовать что-то писать в открытую книгу, если не получится, значит она только для чтения.
 
bigorq, ну макрос по сути и пытается вписать в книгу данные. пользователь который запустил процесс копирования не видит что происходит
 
mitya528, можное еще проверять, есть ли рядом с файлом, временный файл, создаваемый при открытии, в нем видно кто открыл файл (в 2010 офисе, в более свежих не знаю )
Изменено: bigorq - 04.04.2024 16:13:31
 
Код
Private Function myReadOnlyCheck(wb As Workbook) As Boolean
    If wb.ReadOnly Then
        myReadOnlyCheck = True
        MsgBox wb.Name & vbCrLf & "файл открыт для чтения.", vbCritical, "ReadOnly сheck"
        wb.Close False
    End If
End Function
Скрытый текст
 
Вариант, не открывая файл.
Код
Public Function FileIsBusy(File$) As Boolean
    'не открывая файла проверяет, открыт ли он вообще кем-либо
    Dim FN%: FN = FreeFile
    On Error Resume Next
    Open File For Random Access Write Lock Write As #FN
    Close #FN
    FileIsBusy = (Err <> 0)
End Function
 
If FileIsBusy Then Err.Clear или On Error GoTo 0
Не то Err.Number перекочует в родительскую процедуру/функцию  ;)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
И правда.
Хотя в документации пишут, что не перекочует.
Цитата
Без оператора On Error GoTo 0 обработчик ошибок автоматически отключается, когда выполняется выход из процедуры.
Инструкция On Error (VBA) | Microsoft Learn
 
МатросНаЗебре, всё правильно пишут — обработчик отключается. Но код ошибки сохраняется  :D
Изменено: Jack Famous - 04.04.2024 17:45:26
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
МатросНаЗебре,
Цитата
написал:
myReadOnlyCheck
Спасибо, но это только пол дела,
Цитата
написал:
нажму "да" и процесс продолжится
хотелось бы чтобы процесс можно было продолжить, а не просто завершить его. наверное вместо завершения процесса макрос должен запустить сам себя повторно, это вообще возможно?
 
Цитата
Jack Famous написал:
Но код ошибки сохраняется
ну с точки зрения чистоплотности нужно сбросить, но с точки зрения вреда - если в головной процедуре нет обработчика ошибок, то совсем ничего не произойдет
Если есть то произойдет только в случае если идет на проверку ошибки по номеру.
Код
Sub t1()
On Error Resume Next
Debug.Print Err.Number
Call t2
a = B
If Err <> 0 Then Debug.Print Err.Number
End Sub
Sub t2()
On Error Resume Next
a = 1 / 0
' On Error GoTo 0
End Sub


События ошибки нет, даже если номер все еще висит, по этому обработчик не реагирует.

Цитата
МатросНаЗебре написал:
Вариант, не открывая файл.
не учитывает книги с общим доступом.
По вопросам из тем форума, личку не читаю.
 
Код
Private Function myReadOnlyCheck(wb As Workbook) As Boolean
    If wb.ReadOnly Then
        myReadOnlyCheck = True
        MsgBox wb.Name & vbCrLf & "Попроси коллегу закрыть оригинал файла и нажми ''ОК''.", vbCritical, "Сейчас файл открыт только для чтения"
        wb.Close False
    End If
End Function
вот в таком виде после сообщения о том что файл уже у кого то открыт, можно попросить закрыть файл, нажать "ок" и все отработает как было задумано.
Осталось одно необязательное пожелание, хорошо бы в сообщении выводить имя пользователя который открыл файл
Код
Sub aaa()
    
  Application.ScreenUpdating = False  'отключаем обновление экрана для скорости

  Workbooks.Open Filename:="\\s\Files_server\Отдел\_ОБЩАЯ\С\Отбор.xlsm" 'открыть книгу
    Workbooks("Отбор.xlsm").Windows(1).WindowState = xlMaximized 'на первый план
      Workbooks("Отбор.xlsm").Activate 'на первый план
    If myReadOnlyCheck(ActiveWorkbook) Then

  Workbooks.Open Filename:="\\s\Files_server\Отдел\_ОБЩАЯ\С\Отбор.xlsm" 'открыть книгу
    Workbooks("Отбор.xlsm").Windows(1).WindowState = xlMaximized 'на первый план
      Workbooks("Отбор.xlsm").Activate 'на первый план
    
    End If 'конец блока если

  Sheets("ОП").Select 'выбрать лист
    Call Application.Run("'Отбор.xlsm'!Модуль.Очистка") 'запустить макрос
      Excel.ActiveWorkbook.Save 'сохранить книгу
        ActiveWorkbook.Close True 'закрыть книгу без подтверждения

  Sheets("Доп").Select 'выбрать лист
    Range("B4").Select 'выбрать ячейку
      Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
        Selection.Copy 'копировать
          Sheets("Отбор").Select 'выбрать лист
            Range("A2").Select 'выбрать ячейку
              Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                   :=False, Transpose:=False 'вставить только значения
     
  Sheets("Доп").Select 'выбрать лист
    Range("CA4").Select 'выбрать ячейку
      Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
        Selection.Copy 'копировать
          Sheets("Отбор").Select 'выбрать лист
            Range("B2").Select 'выбрать ячейку
              Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                   :=False, Transpose:=False 'вставить только значения
                   
  Sheets("Авто").Select 'выбрать лист
    Range("BZ4").Select 'выбрать ячейку
      Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
        Selection.Copy 'копировать
          Sheets("Отбор").Select 'выбрать лист
            Range("C2").Select 'выбрать ячейку
              Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                   :=False, Transpose:=False 'вставить только значения

  Range("A2:C2").Select 'выбрать диапазон
    Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
      Selection.Copy 'копировать

  Workbooks.Open Filename:="\\s\Files_server\Отдел\_ОБЩАЯ\С\Отбор.xlsm" 'открыть книгу
    Workbooks("Отбор.xlsm").Windows(1).WindowState = xlMaximized 'на первый план
      Workbooks("Отбор.xlsm").Activate 'на первый план

    If myReadOnlyCheck(ActiveWorkbook) Then

  Workbooks.Open Filename:="\\s\Files_server\Отдел\_ОБЩАЯ\С\Отбор.xlsm" 'открыть книгу
    Workbooks("Отбор.xlsm").Windows(1).WindowState = xlMaximized 'на первый план
      Workbooks("Отбор.xlsm").Activate 'на первый план
    
    End If 'конец блока если
    

  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False 'вставить только значения
    Range("A2").Select 'выбрать ячейку
  
  Excel.ActiveWorkbook.Save 'сохранить книгу
  
    If Weekday(Date, 2) = 1 Then 'если сегодня понедельник
      Dim x As String
        strPath = "\\s\Files_server\Отдел\_ОБЩАЯ\С\Архив\Отбор"     'папка для сохранения резервной копии
      On Error Resume Next
        x = GetAttr(strPath) And 0
          If Err = 0 Then ' если путь существует - сохраняем копию книги, добавляя дату-время
            strDate = Format(Now, "dd.mm.yy hh.mm") 'формат сегодняшней даты и времени
              FileNameXls = strPath & "\" & "Отбор" & " " & strDate & ".xlsm" 'название и формат сохраняемого файла
                ActiveWorkbook.SaveCopyAs Filename:=FileNameXls 'сохранить объединив условия
          Else 'если путь не существует - выводим сообщение
            MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical 'сообщение в случае ошибки
          End If 'конец блока если
     End If 'конец блока если
     
  ActiveWorkbook.Close True 'закрыть книгу без подтверждения
    Application.ScreenUpdating = True 'включаем обновление экрана
End Sub 'конец

 
Цитата
Осталось одно необязательное пожелание, хорошо бы в сообщении выводить имя пользователя который открыл файл
Сам не пробовал, но тут советуют Workbook.UserStatus:
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=8&TID=35940

PS. На мой взгляд, код вашего макроса можно упростить, например:
Код
Set r = Sheets("Доп").Range("B4:B" & Sheets("Доп").Range("B4").End(xlDown).Row)
Sheets("Отбор").Range("A2").Resize(r.Count).Value = r.Value
вместо:
Код
Sheets("Доп").Select 'выбрать лист
    Range("B4").Select 'выбрать ячейку
      Range(Selection, Selection.End(xlDown)).Select 'выделить вниз
        Selection.Copy 'копировать
          Sheets("Отбор").Select 'выбрать лист
            Range("A2").Select 'выбрать ячейку
              Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                   :=False, Transpose:=False 'вставить только значения
 
Не стал разбираться в чужом коде (слишком много строк), но у меня в копилке лежит пара приёмчиков, которые можно попытаться заюзать:
Код
Private Function FileIsBusy(File$) As Boolean   ' не открывая файла проверяет, открыт ли он вообще кем-либо
   Dim FN%: FN = FreeFile
   On Error Resume Next
   Open File For Random Access Write Lock Write As #FN
   Close #FN
   FileIsBusy = (Err <> 0)
End Function

Private Sub test_FileIsBusy()
Debug.Print FileIsBusy("C:\Temp\Hotkeys.xls")
End Sub
'-------------------------------------------------
Private Sub test_Статус_Книги()
'Свойство UserStatus возвращает 2D-массив (1, 1 to 3), содержащий информацию:
'UserStatus(1,1) - имя пользователя, открывшего книгу в режиме общего доступа,
'UserStatus(1,2) - дата и время, когда этот пользователь открыл книгу,
'UserStatus(1,3) - режим открытия книги (1 - монопольный доступ, 2 - общий доступ).
Debug.Print IIf(ThisWorkbook.UserStatus(1, 3) = 1, "Exclusive", "Shared")
End Sub

Изменено: Alex_ST - 05.04.2024 09:59:56
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
andypetr,
Цитата
написал:
можно упростить,
Спасибо, обязательно попробую
 
Alex_ST,
Цитата
написал:
UserStatus(1,1)
Спасибо, обязательно попробую
 
Цитата
БМВ написал:
ну с точки зрения чистоплотности нужно сбросить, но с точки зрения вреда - если в головной процедуре нет обработчика ошибок, то совсем ничего не произойдет
чтобы не думать и не запоминать, есть ли в родительской процедуре (прародительской и так далее по всей цепочке) обработчик, а, также, с точки зрения корректной логики (или "чистоплотности", если угодно) — нужно "прибираться" за собой. Это гораздо проще (чем держать в голове обработчики всей цепочки) и правильнее.
    А, что, если в цепочке ПОЯВИТСЯ обработчик которого не было? Вспомнит ли разработчик, что у него номер ошибки гуляет неприкаянный? Очень вряд ли … И нескоро найдёт, откуда ноги действительно растут. В худшем случае, вообще будет "лечить здоровое".
   
    Кстати говоря, инициирование обработчика, его сброс и сброс ошибки — очень быстрые операции. В цикле, конечно, я, всё равно, стараюсь не использовать и выносить за пределы цикла, но, вообще — шустрые.
Изменено: Jack Famous - 08.04.2024 10:35:29
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх