Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Выскакивает окно сохранить, при обработке файла эксель, другим файлом!
 
#1
23.08.2022 09:59:55
Здравствуйте. Имеется отчет который построен с помощью макросов, такой код, по команде, я выбираю папку где имеются другие файлы и эта книга считывает все данные и переносит их в эту книгу как отчет. Те файлы которые проверяются (анализируются, тоже имеют код) в частности стандартное сохранение заменено на (код ниже после этого кода), где пользователь пока не заполнит нужный файл, не сможет сохранить файл. Так вот когда я дополнил в проверяемые файлы свой метод сохранения, теперь при анализе каждого файла у меня выскакивает окно, сохранить да или нет, и пока я не нажму один из вариантов, то следующий файл не анализируется. Как можно поправить этот или тот файл, чтобы если обработка осуществляется другим кодом, то это окно игнорировалось и не выскакивало это окно?
Код
Option Explicit
 
Dim FSO As Object, iFolder As Object, iFile As Object, FD As FileDialog, ExtArray() As Variant
Dim iPath As String, firstAddress As String, iPathName As String, Recursion As Boolean
Dim iSht As Worksheet, iReportSht As Worksheet, iTempWB As Workbook, ExcelVersion As Byte
Dim TextToFind As Variant, ArrayToFind(), iFoundRng As Range, iLastRow As Long, FoundAny As Boolean, iTotalFiles As Long, iAllTotalFiles As Long
Dim FindInValuesOrFormulas As Long, FindInWholeCellOrPart As Long, I As Long
Dim MonIndex As Long
Dim Selection As Range
Dim UseMethod
Dim UseAll As Boolean
Dim UseMonth As Long
 
Const cnstStrHeader As String = "Подразделение,Фамилия И.О.,январь,февраль,март,апрель,май,июнь,июль,август,сентябрь,октябрь,ноябрь,декабрь,*,Составитель,ТН1,ТН1 %,ТН2,ТН2 %,ТН3,ТН3 %"
Dim StrHeader() As String
 
 
Private Sub CommandButton1_Click()
    Call ПоискВоВсехФайлахИПапках
End Sub
 
Private Sub ПеречитатьКаталог()
    Recursion = False: iPathName = "": FoundAny = False
    iTotalFiles = 0
    iAllTotalFiles = 0
    Dim K As Long
 
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    With FD
        .AllowMultiSelect = False
        .Title = "Укажите директорию с файлами для анализа"
        .ButtonName = "Выбрать папку"
        If .Show = False Then Exit Sub Else iPath = .SelectedItems(1) & Application.PathSeparator
    End With
    Set FD = Nothing
 
    'If MsgBox("Просматривать вложенные папки?", vbQuestion + vbYesNo, "Рекурсия") = vbYes Then Recursion = True
    Recursion = True
    UseAll = False
    K = ThisWorkbook.Worksheets("СлужебныеДанные").Cells.Item(15, 1).Value
    If ThisWorkbook.Worksheets("СлужебныеДанные").Cells.Item(15, 1).Value = 0 Then
        UseAll = True
    Else
        UseMonth = ThisWorkbook.Worksheets("СлужебныеДанные").Cells.Item(15, 1).Value
    End If
 
    '------------------
    ' подготовка второго листа для вывода результатов
    '------------------
    ThisWorkbook.Worksheets("Результат").Cells.Range("A1:Z1000").ClearContents
    StrHeader = Split(cnstStrHeader, ",")
    For I = 1 To 22 '14
        ThisWorkbook.Worksheets("Результат").Cells.Item(1, I) = StrHeader(I - 1)
    Next I
    ThisWorkbook.Worksheets("Результат").Range("A1:Z1000").Borders(xlInsideHorizontal).LineStyle = xlNone
    ThisWorkbook.Worksheets("Результат").Range("A1:Z1000").Borders(xlInsideVertical).LineStyle = xlNone
 
    '------------------
    ' работа с файлами
    '------------------
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .StatusBar = "Идёт поиск..."
        .ShowWindowsInTaskbar = False
        '.EnableEvents = False
 
        On Error GoTo ErrHandler:
        ExcelVersion = Val(Application.Version)
        ' здесь указываем, какие расширения будем обрабатывать
        ExtArray = Array("xlsm")
        Set FSO = CreateObject("Scripting.FileSystemObject")
        ОбработатьПодкаталоги (iPath)
        Set iFolder = Nothing
        Set FSO = Nothing
 
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
 
    If FoundAny = False Then
        MsgBox "Файлы, пригодные для обработки, в каталоге " & Chr(10) & iPath & Chr(10) & " не были найдены!", 48, "Ошибка!"
        Exit Sub
    End If
    
    '------------------
    ' сортировка данных о сотрудниках
    '------------------
    Columns("A:A").Select
    ThisWorkbook.Worksheets("Результат").Sort.SortFields.Clear
    ThisWorkbook.Worksheets("Результат").Sort.SortFields.Add Key:=Range("A2:A" & (iTotalFiles + 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ThisWorkbook.Worksheets("Результат").Sort
        .SetRange Range("A1:V" & (iTotalFiles + 1))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    '------------------
    ' форматирование и условное выделение цветом
    '------------------
    ThisWorkbook.Worksheets("Результат").Range("A1:V" & (iTotalFiles + 1)).Borders(xlInsideHorizontal).LineStyle = xlDash
    ThisWorkbook.Worksheets("Результат").Range("A1:V" & (iTotalFiles + 1)).Borders(xlInsideVertical).LineStyle = xlDash
    ThisWorkbook.Worksheets("Результат").Range("A1:V" & (iTotalFiles + 1)).Borders(xlEdgeBottom).LineStyle = xlDash
    ' правило первое (от 70 до 100)
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions.Delete
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, Formula1:="=70", Formula2:="=100"
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(1).Font.Color = -16752384
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(1).Interior.PatternColorIndex = xlAutomatic
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(1).Interior.Color = 13561798
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(1).Interior.TintAndShade = 0
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(1).StopIfTrue = False
 
    ' правило второе (от 50 до 70)
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, Formula1:="=50", Formula2:="=70"
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(2).Font.Color = -16751204
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(2).Interior.PatternColorIndex = xlAutomatic
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(2).Interior.Color = 10284031
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(2).Interior.TintAndShade = 0
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(2).StopIfTrue = False
 
    ' правило третье (ниже 50)
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, Formula1:="=1", Formula2:="=50"
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(3).Font.Color = -16383844
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(3).Interior.PatternColorIndex = xlAutomatic
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(3).Interior.Color = 13551615
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(3).Interior.TintAndShade = 0
    ThisWorkbook.Worksheets("Результат").Range("A1:N" & (iTotalFiles + 1)).FormatConditions(3).StopIfTrue = False
    
ErrHandler:
    '------------------
    ' вывести результаты обработки
    '------------------
    'If iAllTotalFiles > 0 Then iAllTotalFiles = iAllTotalFiles - 1
    'If iTotalFiles > 0 Then iTotalFiles = iTotalFiles - 1
    ThisWorkbook.Worksheets("Управление").Range("файловобработано").Cells.Item(1, 1) = iAllTotalFiles
    ThisWorkbook.Worksheets("Управление").Range("файловсошибками").Cells.Item(1, 1) = iAllTotalFiles - iTotalFiles
    ThisWorkbook.Worksheets("Управление").Range("файловуспешно").Cells.Item(1, 1) = iTotalFiles
    ThisWorkbook.Activate
    Application.GoTo Cells(19, 3)
    
    If Err <> 0 Then MsgBox "Произошла ошибка: " & Err.Number & Chr(10) & Err.Description, 48, "Ошибка"
    With Application
        '.EnableEvents = True
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
ЭТО КОД В ФАЙЛЕ КОТОРЫЙ ПРОВЕРЯЮТ:
Код
Sub Protect_for_User_Non_for_VBA(wsSh As Worksheet)
'    wsSh.Unrotect "111"
    wsSh.Protect Password:="111", AllowFiltering:=True, UserInterfaceOnly:=True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
If ПроверкаИтогов() = False Then
Cancel = True
ActiveWorkbook.Close SaveChanges:=False
MsgBox ("Не совпадают оценки, нажми кнопку применить!!!")
Else
 
Select Case MsgBox("Сохранить и закрыть?", vbOKCancel)
 
Case Is = vbCancel
Cancel = True
 
Case Is = vbOK
ActiveWorkbook.Save
 
End Select
End If
 
End Sub
 
 
 
#2
23.08.2022 11:26:25
Так разкомментируйте строку с .EnableEvents = False, чтобы не срабатывали события в проверяемых файлах перед закрытием.
 
 
 
#3
23.08.2022 11:43:11
Roman M, Здравствуйте. Блин, помогло. Спасибо!  
 
 
 
#4
24.08.2022 17:02:08
Странно, что помогло. Events это другое по идее. В вашем же случае
Код
Application.DisplayAlerts = False
 
 
 
#5
24.08.2022 17:51:53
Цитата
No Name написал:
Странно, что помогло
не странно ни разу, т.к. речь про сообщения из событийной процедуры Workbook_BeforeClose, которая записана в обрабатываемых файлах и вызывается при обработке этих файлов кодом, а не должна.
А DisplayAlerts это про другое немного.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
Страницы: 1
Наверх