Здравствуйте. Имеется отчет который построен с помощью макросов, такой код, по команде, я выбираю папку где имеются другие файлы и эта книга считывает все данные и переносит их в эту книгу как отчет. Те файлы которые проверяются (анализируются, тоже имеют код) в частности стандартное сохранение заменено на (код ниже после этого кода), где пользователь пока не заполнит нужный файл, не сможет сохранить файл. Так вот когда я дополнил в проверяемые файлы свой метод сохранения, теперь при анализе каждого файла у меня выскакивает окно, сохранить да или нет, и пока я не нажму один из вариантов, то следующий файл не анализируется. Как можно поправить этот или тот файл, чтобы если обработка осуществляется другим кодом, то это окно игнорировалось и не выскакивало это окно?
Код
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
Здравствуйте. Подскажите пожалуйста, как мне сделать, чтобы проверочный файл, использовал пароль, для снятия защиты с листов? У меня такой код в книге №1:
Код
Set iTempWB = Workbooks.Open(FileName:=iSubdir & iFile.name, UpdateLinks:=False, ReadOnly:=True, Password:="1234")
Он открывает вторую книгу (не явно, сам для себя) и делает определенные манипуляции, но в той книге необходима защита некоторых ячеек, она установлена с помощью макроса (в ней тоже макрос и он должен выполнятся, поэтому так)
Код
Private Sub Workbook_Open()
Dim arr, sSh
arr = Array("Лист 1", "Лист 2", "Лист 3")
For Each sSh In arr
Protect_for_User_Non_for_VBA Me.Sheets(sSh)
Next
End Sub
Sub Protect_for_User_Non_for_VBA(wsSh As Worksheet)
' wsSh.Unrotect "1234"
wsSh.Protect Password:="1234", AllowFiltering:=True, UserInterfaceOnly:=True
End Sub
Если пароля нет (такого кода), то первая книга спокойно обрабатывает эту книгу, но как только я добавляю этот код, он эту книгу пропускает! Как Быть. Если я устанавливаю явно защиту во второй книге без макроса, то у меня не корректно работает макрос во второй книге. Сделал чтобы и защита была и макрос работал, теперь при проверке его возник вопрос!
строки, то у меня отображается для Листа2, Листа3, Листа4 все нормально (там структура одинакова, 3 цены в одинаковых колонках), а вот в других листах, где по 1 цене (один столбец), а где две цены, вот мне и нужно, чтобы было так, если выпадающем списке я выбираю второй лист, то действовал первый вариант, если лист 5, то второй вариант и т.д.
Добрый день. Подскажите пожалуйста, почему не срабатывает формула! Скорее всего даже дело не в формуле а в диапазоне, как лучше сделать, чтобы все работало? Имеется такая формула:
Она выводит данные описания , с другой =ЕСЛИОШИБКА(ВПР($A5;Прайс.xlsm!Таблица10[#Данные];2;0);""), в определенную строку бланка заказа! в другой строке, есть аналогичная формула, только разумеется ссылается на туже книгу, только другой лист, но и сравнивает другую ячейку. Так вот, вторая формула работает, все нормально (в выпадающем списке выбираем нужную номенклатуру и автоматически подставляется описание этой номенклатуры, а вот в первой формуле нет! Не могу понять почему. Формула ссылается на Диспетчер имен (умная таблица)!
Public Sub GetPointCoordinates(ByVal cellrange As Range, ByRef pointcoordinates As pointcoordinatestype)
Dim i As Long
ConvertUnits
Set cellrange = cellrange.MergeArea
For i = 1 To ActiveWindow.Panes.Count
If Not Intersect(cellrange, ActiveWindow.Panes(i).VisibleRange) Is Nothing Then
pointcoordinates.Left = PixelsToPointsX(ActiveWindow.Panes(i).PointsToScreenPixelsX(cellrange.Left))
pointcoordinates.Top = PixelsToPointsY(ActiveWindow.Panes(i).PointsToScreenPixelsY(cellrange.Top))
pointcoordinates.Right = pointcoordinates.Left + cellrange.Width * zoomratio
pointcoordinates.Bottom = pointcoordinates.Top + cellrange.Height * zoomratio
Exit Sub
End If
Next
End Sub
Здравствуйте. Подскажите пожалуйста, у меня есть много выпадающий список, реализованный средствами vba, как мне прописать в коде, чтобы список выпадал от правого нижнего угла активной ячейки в экселе, а то она выпадает где захочет.
Код
Private Sub UserForm_Initialize()
Dim pointcoordinates As pointcoordinatestype, horizontaloffsetinpoints As Double, verticaloffsetinpoints As Double
With Me
horizontaloffsetinpoints = (.Width - .InsideWidth) / 2
verticaloffsetinpoints = 1
Call GetPointCoordinates(ActiveCell.Offset(0, 1), pointcoordinates)
.StartUpPosition = 0
.Top = pointcoordinates.Top - verticaloffsetinpoints
.Left = pointcoordinates.Left - horizontaloffsetinpoints
End With
Dim ws As Worksheet
' Set wbCurrent = ActiveWorkbook("Бланк заказа") это как было в одной книге, а ниже я пытаюсь обратиться к той книге
Set wbCurrent = Workbooks("Прайс Общий с макросами и многовыпадающитм списком")
For Each ws In wbCurrent.Worksheets
If InStr(1, ws.Name, ".", vbTextCompare) > 0 Then
n = n + 1
Level1.ListBox1.AddItem (ws.Name)
If Len(ws.Name) > lenT Then lenT = Len(ws.Name)
End If
Next
Dim ihWnd, hStyle
If Val(Application.Version) < 9 Then
ihWnd = FindWindow("ThunderXFrame", Me.Caption)
Else
ihWnd = FindWindow("ThunderDFrame", Me.Caption)
End If
hStyle = GetWindowLong(ihWnd, GWL_STYLE)
hStyle = hStyle And Not WS_CAPTION And Not WS_BORDER
SetWindowLong ihWnd, GWL_STYLE, hStyle
SetWindowLong ihWnd, GWL_EXSTYLE, 0
DrawMenuBar ihWnd
Level1.Height = n * 20
Level1.Height = Level1.Height + GWL_EXSTYLE
Level1.Width = lenT * 2
Level1.ListBox1.Height = Level1.Height
Level1.ListBox1.Width = Level1.Width
End Sub
Я так понимаю, что снизу должно быть записано Level1.TextBox1.Top = ???????, и Level1.TextBox1.Left = ???????, только вот, что прописать за равенством
МатросНаЗебре, Здравствуйте. Еще один вопрос. Подскажите, а можно внести в этот код изменения, чтобы после добавления строки кодом, в ячейке количество по умолчанию всегда было 1!
Юрий М, ну тогда как копию сделать, точнее копию то я сделать смогу, как удалять его автоматически при закрытии и делать копию автоматически при входе в документ
Дмитрий(The_Prist) Щербаков,теперь вопрос, я вывел на отдельный лист бланк заказа, как его теперь правильно защитить, чтобы его можно было менять всяко разно, но сохранить нельзя было, если только сохранить как!
Здравствуйте. Подскажите пожалуйста, как запретить сохранять изменения в определенном листе книги эксель. Например у нас есть файл в нем много листов, один из них бланк заказа, так вот юзер может дополнять строки в листе бланк заказа, удалять строки, но при сохранении всей книги, бланк не сохранялся, а если есть изменения на других листах то должно сохранится, потому что на других листах содержится номенклатура, а бланк мы проста с помощью выпадающих списков наполняем, как наполнили распечатали или сохранили как и все!
SAS888,все понял, свой код то не вставил, а как еще указать, чтобы код данный срабатывал ТОЛЬКО В ПЕРВОМ СТОЛБЦЕ, но ТАКЖЕ МЕЖДУ СТРОКАМИ. Сейчас код свой вставил, все работает, но только во всех столбцах, а мне нужно только в первом
МатросНаЗебре, все понял, свой код то не вставил, а как еще указать, чтобы код данный срабатывал ТОЛЬКО В ПЕРВОМ СТОЛБЦЕ, но ТАКЖЕ МЕЖДУ СТРОКАМИ. Сейчас код свой вставил, все работает, но только во всех столбцах, а мне нужно только в первой