Для создания/удаления временных наборов запросов хотел бы найти vba-метод создания pq-запроса в составе группы, для последующего удаления всей группы, вместо удаления каждого запроса по отдельности (т.к. состав м.б. разным, а в обработчике много других, постоянных запросов)
У MS есть раздел 'Manage queries (Power Query)' c командами меню, но vba-команды пока не находятся ...
Коллеги, здравствуйте! Хотел бы создать универсальную таблицу-шаблон-накопитель с заданными типами данных для столбцов, чтобы впоследствии транслировать типы данных по наименованиям столбцов одновременно в несколько последующих запросов (проработку начал из темы Задать для всех столбцов один тип в Power Query)
После первой сработки макрос прекращает реагировать на событие BeforeSave Цель: принудительное сохранение файла в заранее определенном формате Возможно, код не отрабатывает полностью процедуру ... не могу разобраться
Код
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
Application.EnableCancelKey = xlDisabled
Application.EnableEvents = False
Cancel = True
Dim fName As Variant
Dim FileFormatValue As Long
With Application
fName = .GetSaveAsFilename(InitialFileName:=ActiveWorkbook.Name, FileFilter:=" Excel Binary Workbook (*.xlsb), *.xlsb", FilterIndex:=1, Title:="Save as .xlsb")
End With
' Find the correct FileFormat that matches the choice
' in the "Save as type" list.
Select Case getExtension(fName)
Case "xlsb": FileFormatValue = 50 'xlExcel12 '50
Case Else: FileFormatValue = 50
End Select
If fName = False Then GoTo NotSaved ' When user selects Cancel.
On Error Resume Next
'Exit Sub
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fName, FileFormat:=FileFormatValue, CreateBackup:=False
'DoEvents
If Err.Number <> 0 Then
On Error GoTo 0
GoTo NotSaved
Else
On Error GoTo 0
'MsgBox "Project successfully saved.", vbInformation ' Exit Sub '
End If
Application.EnableCancelKey = xlInterrupt
Exit Sub '
NotSaved:
'MsgBox "Project Not Saved!", vbExclamation ' Exit Sub '
ActiveWorkbook.Activate
Application.EnableCancelKey = xlInterrupt
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Проблема с сохранением файла в принудительном формате, после отработки кода на событие Workbook_BeforeSave книга надолго повисает и в итоге вылетает совсем
Причем, при перезаписи файла кодом, макрос в дальнейшем прекращает срабатывать, а при сохранении в новое имя как раз виснет, часики крутятся, затем вылетает
Код
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableCancelKey = xlDisabled
Application.EnableEvents = False
Dim fName As Variant
Dim FileFormatValue As Long
With Application
fName = .GetSaveAsFilename(InitialFileName:=ActiveWorkbook.Name, FileFilter:=" Excel Binary Workbook (*.xlsb), *.xlsb", FilterIndex:=1, Title:="Save as .xlsb")
End With
' Find the correct FileFormat that matches the choice
' in the "Save as type" list.
Select Case getExtension(fName)
Case "xlsb": FileFormatValue = 50 'xlExcel12 '50
Case Else: FileFormatValue = 50
End Select
If fName = False Then GoTo NotSaved ' When user selects Cancel.
On Error Resume Next
'Exit Sub
ActiveWorkbook.SaveAs fName, FileFormat:=FileFormatValue, CreateBackup:=False
'DoEvents
If Err.Number <> 0 Then
On Error GoTo 0
GoTo NotSaved
Else
On Error GoTo 0
'MsgBox "Project successfully saved.", vbInformation ' Exit Sub '
End If
Application.EnableCancelKey = xlInterrupt
Exit Sub '
NotSaved:
'MsgBox "Project Not Saved!", vbExclamation ' Exit Sub '
ActiveWorkbook.Activate
Application.EnableCancelKey = xlInterrupt
Application.EnableEvents = True
End Sub
Настраиваю принудительное сохранение в формате *.xlsb, но не могу поймать и отключить момент повторного открытия диалога SaveAs
Module1
Код
Function getExtension(ByVal fName As String) As String
getExtension = LCase(Right(fName, Len(fName) - InStrRev(fName, ".")))
End Function
ЭтаКнига
Код
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim fName As Variant
Dim FileFormatValue As Long
With Application
fName = .GetSaveAsFilename(InitialFileName:=ActiveWorkbook.Name, FileFilter:=" Excel Binary Workbook (*.xlsb), *.xlsb", FilterIndex:=1, Title:="Save as .xlsb")
End With
' Find the correct FileFormat that matches the choice
' in the "Save as type" list.
Select Case getExtension(fName)
Case "xlsb": FileFormatValue = 50
Case Else: FileFormatValue = 0
End Select
If fName = False Then GoTo NotSaved ' When user selects Cancel.
On Error Resume Next
'Exit Sub
ActiveWorkbook.SaveAs fName, FileFormat:=FileFormatValue, CreateBackup:=False
If Err.Number <> 0 Then
On Error GoTo 0
GoTo NotSaved
Else
On Error GoTo 0
Exit Sub 'MsgBox "Project successfully saved.", vbInformation
End If
Exit Sub '
NotSaved:
Exit Sub 'MsgBox "Project Not Saved!", vbExclamation
End Sub
При получении в массив единственного элемента, вход в цикл For each возвращает ошибку Run-time error '13': Type mismatch Если в массиве два и более элементов, цикл отрабатывает
Код
Dim ВыкладкаФайлы As Variant
Sheets("Генератор").Select
lLastRow = Sheets("Генератор").Cells(Rows.Count, 19).End(xlUp).Row
Sheets("Генератор").Range(Cells(1, 19), Cells(lLastRow, 19)).Select
ВыкладкаФайлы = Selection.Value2
For Each Filename In ВыкладкаФайлы ' здесь Run-time error '13': Type mismatch
Debug.Print Filename
Первично, хотел бы только узнать, возможно ли такое вообще ... (два уровня вложенности)
Данные в исходной таблице – несколько категорий (сгруппированы по SKU) Оцениваемая категория – через меру, одна категория на вход в визуализацию, определение доли товара в Адресе (для присвоения статуса "много/мало/нормально")
Необходимо получить параметры файла-первоисточника для идентификации данных в итоговом массиве Хотелось бы решить вопрос для первой строки в текущем столбце – потому что планируется большое количество любых файлов и очень большие данные
Помогите пож-та встроить в функцию возможность проверки из нескольких вариантов для RegExp
Читаю тему 'Регулярные выражения (RegExp) в Power Query', вижу строку var pattern = /" & regex & "/gi;, но такой практики пока не имеется, чтобы самому перестроить на получение списка из таблицы с вариантами проверки регэкспов. У меня их 15 штук, поэтому хотелось бы разработать одно решение, вместо 15 разных. (причем, в моем случае, нужна простая проверка значения на наличие регэкспа, есть, или нет; и при наличии промаркировать соответствующим термином из той же таблицы с регэкспами - это уже целевая задача)
Код
let fx=(txt as text, regex as text, delim as text)=>
Web.Page(
"<script>
var x = '" & txt & "';
var delim = '" & delim & "';
var pattern = /" & regex & "/gi;
var result = x.match(pattern).join(delim);
document.write(result);
</script>")[Data]{0}[Children]{0}[Children]{1}[Text]{0}
in
fx
Уважаемые коллеги, направьте пож-та в нужное русло:
Проблема: заголовки столбцов не только меняются местами, но и регулярно переименовываются в ежеквартальном/ежемесячном цикле. Для квартальных ужасает наличие похожих столбцов с данными неактуальных кварталов
Главная цель – отсеять все, кроме столбца по текущему кварталу (в данном случае текущий квартал 2 - его необходимо сохранить), в таблице заранее создан столбец с номером квартала 2
Имеются след наименования столбцов:
условия работы в 1-м кв 2020
условия 2 кв 2020
условия работы в 3 м кв 2020
В процессе решения я обратил внимание на функцию сохраняющую/удаляющую столбцы по общему признаку:
Код
УдаленыСтолбцыМатр = Table.RemoveColumns(ЧистыеНаимСтолбцов, List.Select(Table.ColumnNames(ЧистыеНаимСтолбцов), each Text.Contains(_, "матр"))),
... вследствие чего возникла идея поочередно присваивать единый префикса столбцам, наименованиями соответствующими маскам/шаблонам, и последующим сохранением Table.SelectColumns() в таблице только столбцов с этим покритериально расставленным префиксом
Пытаюсь в PQ создать выч. столбец, в котором каждая строка с адресом должна быть промаркирована "1" в случае, если в столбце "Тип реализации" с таким адресом хоть раз встречается критерий "Бонус"
В процессе встраивания кода, автоматизируемый файл стал на одном из этапов выдавать сообщение error 1004 Application-defined or object-defined error Причем, пока делал части кода на маленьком файле - никаких ошибок не возникало. Как только начал объединять код в едином файле (в т.ч. нужно чтобы выполнялось два разных действия по WorksheetChange - об этом позже), ошибки пошли более-менее серийно. И вновь, как только подготовил небольшой файл примера, два срабатывания из трех код начал отрабатывать без error 1004.
Цель: автоматизировать реестр на 10000 записей Порядок срабатывания кода: 1. WorkbookOpen - прописание ключевых формул и перекрытие значков примечаний белыми треугольниками 2. WorksheetChange - расширенный фильтр реестра по критерию в единственной ячейке, сохранение истории изменения ячеек (в ст. 1, 42, 49), вставка дат в соседние ячейки 3. WorkbookBeforeSave - удаление треугольников, скрывающих индикаторы примечаний (в большом рабочем файле идет вывод ошибки 1004)
Также, довольно долго для WorksheetChange объединял расширенный автофильтр и сохранение истории в примечания - буду благодарен, если порекомендуете любую оптимизацию кода
Код
Private Sub
Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Update 20141110 Sub RemoveIndicatorShapes()
'Dim pWs As Worksheet
'Dim pShape As Shape
Dim pWs As Worksheet
Dim pComment As Comment
Dim pRng As Range
Dim pShape As Shape
Set pWs = Application.ActiveSheet
For Each pShape In pWs.Shapes
If Not pShape.TopLeftCell.Comment Is Nothing Then 'в этой строке дебаг дает желтую подсветку
If pShape.AutoShapeType = msoShapeRightTriangle Then
pShape.Delete
End If
End If
Next
Пока формулировал цель, подготовил два примера (архив, из-за ограничения сайта на размер файла)
Цель: получить стоимость продаж не более 6 ед. продукции в каждой торговой точке для последующего расчета размера скидки (от зачтенной суммы продажи) Второе - просто, первое - сложно, потому что не могу разобраться, как получить часть стоимости, например, 1 ед. из 5 проданных ед., т.е. в торговой точке неск. сумм продаж по 5 ед. и нам нужно выделить из них как 5+1, определив совокупную стоимость, далее рассчитать размер заложенной скидки в 20%
Поскольку пол дня пытаюсь найти способ решения через сводную, не совсем уверен, ясно ли и однозначно я сформулировал свою задачу
Пример 01 - сама задача Пример 02 - попробовал формулами приблизиться к решению
Помогите пож-та скорректировать код, таким образом, чтобы обновлялись данные во всех таблицах кроме таблицы 'Сводная таблица7' на листе 'Прогноз', или кроме всего листа 'Прогноз'
стандартно использую команду ActiveWorkbook.RefreshAll, но ради большой экономии времени необходимо промахнуться мимо тяжелого источника данных
или использую код:
Код
Sub RefreshAllPivotTables()
t = Timer
Dim PT As PivotTable
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
For Each PT In WS.PivotTables
PT.RefreshTable
Next PT
Next WS
MsgBox "???" & Chr(10) & "???: " & TimeSerial(0, 0, (Timer - t)) & " ???.", vbInformation + vbMsgBoxSetForeground + vbSystemModal
End Sub
Уважаемые эксперты, посоветуйте пож-та доработку кода на предмет переборки в папке не выбранных в массив файлов и совершения с каждым одиночной операции с последующим сохранением. Цель всего мероприятия - пересборка массива с исключением из него более не выбранных в диалоговом окне файлов
Код
Sub ВыбратьФайлы()
t = Timer
Dim vFolders(), lCount As Long
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim sFolder As String, sFiles As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Title = "Выбрать файлы выгрузок 1С" 'заголовок окна диалога
.Filters.Clear 'очищаем установленные ранее типы файлов
.Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
' .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
.FilterIndex = 1 'устанавливаем тип файлов по умолчанию - xls files(Текстовые файлы)
.InitialFileName = ActiveWorkbook.Sheets("БД").Range("B2").Value ' = sFolder С:\Temp\Книга1.xlsx" 'назначаем папку отображения и имя файла по умолчанию
.InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
If .Show = False Then Exit Sub
For lf = 1 To .SelectedItems.Count
X = .SelectedItems(lf) 'считываем полный путь к файлу
Workbooks.Open X 'открытие книги
'можно также без х
'Workbooks.Open .SelectedItems(lf)
ТиповойФайл
' ? открытие остальных файлов папки
' ? постановка отметки о неучастии в массиве
' ? выход с сохранением
Next
End With
Application.ScreenUpdating = True
MsgBox "Обновлены остатки" & Chr(10) & Chr(10) & "Первичная дата выгрузки: " & ActiveWorkbook.Sheets("БД").Range("J1").Value & Chr(10) & Chr(10) & "Готово за: " & TimeSerial(0, 0, (Timer - t)) & " сек.", vbInformation + vbMsgBoxSetForeground + vbSystemModal
End Sub
Пытаюсь настроить Outlook периодическую отправку писем (нашел только способ эмуляции кнопки 'Отправить/Получить'), именно excel'ем отправлять почту не хотелось бы, рассматриваю как вариант с жестко прописанным расписанием (типа Application.OnTime), так и через прибавляемый интервал (тогда вынужден ловить время и запускать макрос строго в начале новой минуты, что не очень удобно само по себе, а также, если компьютер иногда засыпает - интервал сдвигается от начала минуты); идеал мечты: отправка почты каждые 5 минут в 01 секунду текущего времени кратного пяти минутам
Сразу извиняюсь за оффтоп, но самых квалифицированных спецов по vba в первую очередь знаю именно отсюда
Приведу текущий рабочий код:
1. В модуле приложения ThisOutlookSession
Код
Private Sub Application_Startup()
Call Module2.TimerStart
End Sub
Public Sub Syn()
Dim nsp As Outlook.NameSpace
Dim sycs As Outlook.SyncObjects
Dim syc As Outlook.SyncObject
Dim i As Integer
Dim strPrompt As Integer
Set nsp = Application.GetNamespace("MAPI")
Set sycs = nsp.SyncObjects
For i = 1 To sycs.Count
Set syc = sycs.Item(i)
strPrompt = vbYes
If strPrompt = vbYes Then
syc.Start
End If
Next
End Sub
2. В стандартном Модуле2
Код
Option Explicit
Dim iTmr As LongLong
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As LongLong, ByVal nIDEvent As LongLong, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongLong) As LongLong
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongLong, ByVal nIDEvent As LongLong) As LongLong
Public Sub TimerStart()
''' If iTmr Then KillTimer 0, iTmr 'Убить старый таймер 'Отлично работает однократно
''' iTmr = SetTimer(0, 0, 15000, AddressOf TimerProc)
If iTmr Then TimerProc ''Отлично работает каждую минуту с момента запуска
iTmr = SetTimer(0, 0, 60000, AddressOf TimerProc)
End Sub
Sub EndTimer()
iTmr = KillTimer(0, iTmr)
End Sub
Private Sub TimerProc()
On Error GoTo errr
'Call EndTimer
Call ThisOutlookSession.Syn
errr:
End Sub
В продолжение темы И снова уникальные значения в массиве (vba) - отсюда имеется код, собирающий уникальные из столбца и присваивающий всем значениям порядковые номера. Хотел бы упростить код, чтобы в массиве находились только уникальные (без порядковых номеров), многое перепробовал. Изменение Resize(x - 1, 2) на (x - 1, 1) на содержимое массива не влияет
Конечная цель - использовать массив для организации цикла по уникальным значениям (цикл For Each x In arr2 отрабатывает повторное количество итераций по несуществующим критериям, предполагаю, что по присвоенным номерам, т.к. кол-во лишних операций равно размеру массива уникальных), продолжаю искать решение
Код
Sub qqq()
Dim Uniq As New Collection, LastRow As Long, i As Long, j As Long, iValue, Arr(), Arr2(), x
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Arr = Range(Cells(2, 1), Cells(LastRow, 1)).Value
For i = 1 To UBound(Arr, 1)
On Error Resume Next
Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
Next
ReDim Arr2(1 To Uniq.Count, 1 To 2)
x = 1
For i = 1 To Uniq.Count
iValue = Uniq(i)
For j = 1 To UBound(Arr, 1)
If Arr(j, 1) = iValue Then
Arr2(x, 1) = iValue
Arr2(x, 2) = i '+ 1
x = x + 1
Exit For
End If
Next
Next
[E2].Resize(x - 1, 2) = Arr2
End Sub
... пробую подобрать вариант через CALCULATE, но до конца не понимаю, как она работает, или просто неправильно делаю... и так прошло несколько дней...
Цель: вычислить для Руководителя коэф. продаж в регионе из расчета на 1 чел. населения .........................(не могу создать меру для вычисления размера населения подотчетного региона) .........................(сложность: регион руководителя определяется через связь регион-контрагент-менеджер-руководитель
Имеется:...........- Таблица Продажи .........................- справочник Население (город-регион) .........................- справочник Менеджеры (менеджер-руководитель)
В таблице PowerBI не могу (или не знаю как) получить колонку уровня изменения показателя к периоду предыдущего года. Ещё этот показатель называется Отклонение.
Делал следующее:
- Создал меру ПродажиГодНазад = CALCULATE([ВыручкаФакт];SAMEPERIODLASTYEAR('ПродажиФакт'[Дата]))
- Создал меру Динамика = DIVIDE('ПродажиФакт'[ВыручкаФакт]-[ПродажиГодНазад]; [ПродажиГодНазад]; BLANK())
- Получил только корректное итоговое значение выручки тек. года к предыдущему 100,25% (при помещении меры в таблицу в месяцам - таблица падает)
Проблема - не могу применить показатель 'изменение' в таблице, или что-то делаю не так. Попытки настроить 'Итоги по' без успеха; дополнительные вычисления не предусмотрены. Буду рад любому совету
Визуальных различий не заметил. Ctrl+L я использую в параллельной программе для расположения окон на мониторе. Может стоит вернуть это сочетание в Excel?
Уважаемые профессионалы, поскольку циклами и синтаксисом владею в основном копи-пастом, помогите пож-та привести код к возможности копировать папки по началу наименования в списке.
Имеется короткий код копирования папок откуда-куда. Хотел бы настроить его так, чтобы: - начало наименования папки бралось из столбца А, начиная с ячейки A2 - адрес исходящей папки (где искать) в D1 - адрес конечной папки копирования в D2 - (по возможности) в столбце B макрос указывал результат (скопирован, не скопирован, отсутствует)
Код
Sub Макрос1_FSOCopyFolder()
On Error Resume Next
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFolder "D:\откуда\*", "D:\куда\", 0
End Sub