Аууу vikttur, ну что поможете с моей проблемкой? Или не ждать ответа?
Название темы должно отражать суть задачи.
Темы типа "ПОМОГИТЕ!!!", "Срочно!" и т.п. будут удаляться без объяснения причин
В этом разделе можно просмотреть все сообщения, сделанные этим пользователем.
Просмотр сообщенийстраница &P"
прибавить ячейку из листа "Титульник" ячейка "V1". Вот макрос:Sub Колонтитулы_Протокол()
Application.ScreenUpdating = False
Sheets("Протокол").Select
Range("V1").Select
ActiveCell.FormulaR1C1 = "=страниц_на_листе_ПРОТ"
Range("V1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With ActiveSheet.PageSetup
.LeftFooter = [Q1] & ". Общее количество страниц " & [T1] & ", страница &P"
End With
Sheets("Титульник").Select
Range("V1").Select
ActiveCell.FormulaR1C1 = "=страниц_на_листе_ТИТ"
Range("V1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With ActiveSheet.PageSetup
.LeftFooter = [Q1] & ". Общее количество страниц " & [T1] & ", страница &P"
End With
Application.ScreenUpdating = True
End Sub
Sub Get_Value_From_Close_Book()
Dim sShName As String, sAddress As String, vData
'Отключаем обновление экрана
Application.ScreenUpdating = False
Workbooks.Open "C:\Documents and Settings\Книга1.xls" '"
sAddress = "A1:C100" 'или одна ячейка - "A1"
'получаем значение
vData = Sheets("Лист1").Range(sAddress).Value
ActiveWorkbook.Close False
'Записываем данные на активный лист книги,
'с которой запустили макрос
If IsArray(vData) Then
[A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
Else
[A1] = vData
End If
'если надо копировать ячейки с форматами,
'то можно использовать стандартные методы копирования вставки
'objCloseBook.Sheets("Лист1").Range(sAddress).Copy
'[A1].PasteSpecial xlPasteValues 'вставляем значения
'[A1].PasteSpecial xlPasteFormats 'вставляем форматы
'Включаем обновление экрана
Application.ScreenUpdating = True
End Sub
Sub Extract_Unique()
Dim x, avArr, li As Long
Dim avVals
Dim rVals As Range, rResultCell As Range
On Error Resume Next
'запрашиваем адрес ячеек для выбора уникальных значений
Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "C2:C51", Type:=8)
If rVals Is Nothing Then 'если нажата кнопка Отмена
Exit Sub
End If
'если указана только одна ячейка - нет смысла выбирать
If rVals.Count = 1 Then
MsgBox "Для отбора уникальных значений требуется указать более одной ячейки", vbInformation, "www.excel-vba.ru"
Exit Sub
End If
'отсекаем пустые строки и столбцы вне рабочего диапазона
Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
'если указаны только пустые ячейки вне рабочего диапазона
If rVals Is Nothing Then
MsgBox "Недостаточно данных для выбора значений", vbInformation, "www.excel-vba.ru"
Exit Sub
End If
avVals = rVals.Value
'запрашиваем ячейку для вывода результата
Set rResultCell = Application.InputBox("Укажите ячейку для вставки отобранных уникальных значений", "Запрос данных", "A2", Type:=8)
If rResultCell Is Nothing Then 'если нажата кнопка Отмена
Exit Sub
End If
'определяем максимально возможную размерность массива для результата
ReDim avArr(1 To Rows.Count, 1 To 1)
'при помощи объекта Коллекции(Collection)
'отбираем только уникальные записи,
'т.к. Коллекции не могут содержать повторяющиеся значения
With New Collection
On Error Resume Next
For Each x In avVals
If Len(CStr(x)) Then 'пропускаем пустые ячейки
.Add x, CStr(x) 'если добавляемый элемент уже есть в Коллекции - возникнет ошибка
'если же ошибки нет - такое значение еще не внесено,
'добавляем в результирующий массив
If Err = 0 Then
li = li + 1
avArr(li, 1) = x
Else
'обязательно очищаем объект Ошибки
Err.Clear
End If
End If
Next
End With
'записываем результат на лист, начиная с указанной ячейки
If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr
End Sub
Sub Extract_Unique()
Dim x, avArr, li As Long
Dim avVals
Dim rVals As Range, rResultCell As Range
On Error Resume Next
'запрашиваем адрес ячеек для выбора уникальных значений
Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "A2:A51", Type:=8)
If rVals Is Nothing Then 'если нажата кнопка Отмена
Exit Sub
End If
'если указана только одна ячейка - нет смысла выбирать
If rVals.Count = 1 Then
MsgBox "Для отбора уникальных значений требуется указать более одной ячейки", vbInformation, "www.excel-vba.ru"
Exit Sub
End If
'отсекаем пустые строки и столбцы вне рабочего диапазона
Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
'если указаны только пустые ячейки вне рабочего диапазона
If rVals Is Nothing Then
MsgBox "Недостаточно данных для выбора значений", vbInformation, "www.excel-vba.ru"
Exit Sub
End If
avVals = rVals.Value
'запрашиваем ячейку для вывода результата
Set rResultCell = Application.InputBox("Укажите ячейку для вставки отобранных уникальных значений", "Запрос данных", "E2", Type:=8)
If rResultCell Is Nothing Then 'если нажата кнопка Отмена
Exit Sub
End If
'определяем максимально возможную размерность массива для результата
ReDim avArr(1 To Rows.Count, 1 To 1)
'при помощи объекта Коллекции(Collection)
'отбираем только уникальные записи,
'т.к. Коллекции не могут содержать повторяющиеся значения
With New Collection
On Error Resume Next
For Each x In avVals
If Len(CStr(x)) Then 'пропускаем пустые ячейки
.Add x, CStr(x) 'если добавляемый элемент уже есть в Коллекции - возникнет ошибка
'если же ошибки нет - такое значение еще не внесено,
'добавляем в результирующий массив
If Err = 0 Then
li = li + 1
avArr(li, 1) = x
Else
'обязательно очищаем объект Ошибки
Err.Clear
End If
End If
Next
End With
'записываем результат на лист, начиная с указанной ячейки
If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr
End Sub
Цитата: Дмитрий Щербаков(The_Prist) от 14.02.2020, 08:55:12.
Если нет - то и триггер не сможет, т.к. ему так же будут переданы привилегии вызывающего пользователя.
А если да - то и триггер не нужен и заносить можно напрямую скриптом(открыть им нужную таблицу, внести данные и закрыть)