Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 След.
Получить максимальную дату из PivotCache (если в самой сводной таблице она не выведена), VBA
 
Коллеги, добрый день,

Ищу оптимальный способ получить в одну ячейку значение максимальной даты данных кеша сводной таблицы
Нигде не нашел, в т.ч. в англоязычных источниках
Обновить все Сводные таблицы кроме, VBA
 
Цитата
buchlotnik написал:
If PT.Name <>  "Сводная таблица7" then PT.RefreshTable
Результат не заставил себя ждать - обновился в 22 раза быстрее
Большое Вам спасибо!
Обновить все Сводные таблицы кроме, VBA
 
Коллеги, добрый день,

Помогите пож-та скорректировать код, таким образом, чтобы обновлялись данные во всех таблицах кроме таблицы 'Сводная таблица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

Перебор файлов в папке вне выбранного списка, VBA
 
Nordheim, давно пытаюсь понимать эти механики, что-то по смыслу понятно, что-то уже обсуждено или увидено, а к чему-то непонятно с какой стороны подходить... вот Вы меня и направили - большое спасибо!
Перебор файлов в папке вне выбранного списка, VBA
 
Sanja, Игорь, большое вам спасибо! Пока ещё полностью не разобрался что делают конструкции .SelectedItems(lf) и sFiles = Dir (что это за синтаксис с точкой), но работает всё шикарно как в аптеке))
Буду благодарен, если направите где можно почитать об операциях с переменными как iWb.Name, iWb.Close True, хотелось бы лучше понять что и как таким способом возможно с переменными делать
Перебор файлов в папке вне выбранного списка, VBA
 
Игорь, да, весь процесс касается планирования ресурсов. Шаг чуть причесать выборочные файлы выгрузок 1С для последующей PQ сборки плоского массива из них.
Пришел к выводу, что неактуальные файлы могут изыматься/возвращаться в массив при любом невыборе/выборе в диалоговом окне. Некоторые элементы работы с переменными мною до конца не изучены, в то же время не пытаюсь целиковую разработку сделать чужими руками. Спасибо за комментарий
Перебор файлов в папке вне выбранного списка, VBA
 
Не совсем понимаю, что я делаю не так:

      Set СписокФайлов = Array(iStr)

никак не могу запустить поочередное открытие файлов из массива "вне списка"
Перебор файлов в папке вне выбранного списка, VBA
 
Уважаемые эксперты, посоветуйте пож-та доработку кода на предмет переборки в папке не выбранных в массив файлов и совершения с каждым одиночной операции с последующим сохранением. Цель всего мероприятия - пересборка массива с исключением из него более не выбранных в диалоговом окне файлов
Код
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
Аналог VBA-команды для Outlook (отправка писем по расписанию), Application.OnTime TimeValue("17:00:01"), "my_Procedure"
 
Цитата
БМВ написал:
обратится к приложения из VBS скрипта
Если можете, направьте пож в какую сторону копать... Где-то видел что-то про VB, но не распознал как полезное
Аналог VBA-команды для Outlook (отправка писем по расписанию), Application.OnTime TimeValue("17:00:01"), "my_Procedure"
 
БМВ, я решаю задачу полной фиксации времени ухода почты. Точнее говоря, мне нужно, чтобы вся рассылка висящая в папке Исходящие, отправилась получателям с 1 по 29 секунду заданной минуты отправки почты, письма ушедшие в 31 секунду датируются уже следующей минутой по простому математическому округлению

БМВ, через SMTP с этим методом я не знаком (кстати, почта на imap, если это играет роль), а Планировщик упирается в ту же проблему Аутлука - отсчет интервала до следующей проверки почты начинается с момента полного завершения предыдущей проверки почты (а не с момента её начала - тогда всё было бы идеально), проблема решается полным закрытием Аутлука, при новом запуске, в т.ч. Планировщиком, Аутлук безусловно проверяет почту и все исходящие уходят вовремя.

Но каждый раз перед рассылкой выключать почту тоже не очень комильфо, вот я и думаю, как отвязаться от времени суток и первой точки отсчета с приращением на заданный интервал...  
Аналог VBA-команды для Outlook (отправка писем по расписанию), Application.OnTime TimeValue("17:00:01"), "my_Procedure"
 
БМВ, большое спасибо за Ваш ответ, к сожалению, данный метод не гарантирует отправку периодической почты в строго единообразное время

 
Аналог VBA-команды для Outlook (отправка писем по расписанию), Application.OnTime TimeValue("17:00:01"), "my_Procedure"
 
Коллеги, добрый день,

Пытаюсь настроить 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

Буду благодарен любому ответу
Поиск дубликатов в КНИГЕ
 
Цитата
Hugo написал:
P.S. Я бы не использовал слово Current как имя переменной...
За рекомендацию отдельное спасибо!
Поиск дубликатов в КНИГЕ
 
Hugo, не удивлен, насколько быстро Вы указали на причину и на ошибку. Большое Вам спасибо! Всё отлично посчиталось, продолжаю осваивать vba      
Поиск дубликатов в КНИГЕ
 
Уважаемые эксперты, в продолжение темы, пытаюсь настроить макрос на поиск дубликатов на всех листах книги в диапазоне H:I, кроме листа Сводная, но, видимо, совсем всё сломалось, код стал выводить ошибку в строке: aa.Resize(Dict.Count) = Application.Transpose(Dict.keys)  

Обходить лист Сводная вроде получилось, а определить диапазон нет, результат хотел бы получать на лист Сводная!C2

сам код и файл здесь:
Код
Sub FindDuplicates()

       ' Declare Current as a worksheet object variable.
         Dim Current As Worksheet


Dim Dict As Object, aa As Range, arr()
Set Dict = CreateObject("Scripting.Dictionary")
         
         ' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
For Each aa In Sheets(1).Range("H2:I60000") '[H2:I60000]
If aa <> "Сводная" Then
  If Len(aa.Value) > 0 Then
    If Not Dict.exists(aa.Value) Then
      Dict.Add aa.Value, 1
    Else
      Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
    End If
  End If
End If
Next
Next


On Error Resume Next
Set aa = Application.InputBox("Select distination cell.", , , , , , , 8)
If aa <> "Сводная" Then
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys)
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End If

End Sub
Уникальные значения в массиве (vba), тема в архиве: И снова уникальные значения в массиве (vba)
 
Nordheim, большое Вам спасибо за метод, повод услышать мнения, где методы эффективны))
Уникальные значения в массиве (vba), тема в архиве: И снова уникальные значения в массиве (vba)
 
Цитата
Пытливый написал:
по каждому элементу коллекции Uniq и делайте, что нужно
Пытливый, Вы правы, я излишне взялся за arr2, в то время как мне нужен только Uniq, с первой попытки всё прошло как надо! Большое Вам спасибо!  
Уникальные значения в массиве (vba), тема в архиве: И снова уникальные значения в массиве (vba)
 
Коллеги, добрый день,

В продолжение темы И снова уникальные значения в массиве (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
Изменено: Дмитрий Марков - 16 Янв 2019 23:11:35
Коэф. продаж руководителя в регионе из расчета на 1 чел. населения, PBI
 
Андрей VG, огромное Вам спасибо! Работает отлично. С Вашей помощью пришел к большему пониманию работы CALCULATE  
Коэф. продаж руководителя в регионе из расчета на 1 чел. населения, PBI
 
... пробую подобрать вариант через CALCULATE, но до конца не понимаю, как она работает, или просто неправильно делаю... и так прошло несколько дней...

Цель: вычислить для Руководителя коэф. продаж в регионе из расчета на 1 чел. населения
.........................(не могу создать меру для вычисления размера населения подотчетного региона)
.........................(сложность: регион руководителя определяется через связь регион-контрагент-менеджер-руководитель

Имеется:...........- Таблица Продажи
.........................- справочник Население (город-регион)
.........................- справочник Менеджеры (менеджер-руководитель)
Изменено: Дмитрий Марков - 18 Авг 2018 11:13:10
Установка надстройки Powerpivot, Excel 2016
 
Цитата
PooHkrd написал:
сводную из запроса PQ (он же скачать и преобразовать)
Как раз я дошел до окна редактора запросов, и меры создаются, модель не нашел, но больше всего мне нужен функционал PP по вычисляемым полям и KPI, который встроенный в excel проще реализован, а созданный в PP хорошо передается в PBI

Цитата
PooHkrd написал:
РР это серьезный инструмент, неужто жалко 1.8к в год за О365Персонал?
Конечно же не жалко, комп рабочий, а в компании политики/лицензии, что быстро получу проф. пакет, не факт, потому ищу более оперативный вариант,  
Установка надстройки Powerpivot, Excel 2016
 
С Dax'ом пока не очень, надо динамические вычислять показатели... потом они ещё не хотят вставать и рассчитываться в нужных мне столбцах... т.е. есть трудности с пониманием работы работы мер  
Установка надстройки Powerpivot, Excel 2016
 
Цитата
ADimov написал:
Может на данный момент найдено решение, как прикрутить PowerPivot
Столкнулся с аналогичной сложностью - отсутствует в списке надстроек COM, ругается когда пытаюсь ставить msi поверх Excel
Нужно для расчета показателей и последующей их отдачи в Power BI (т.к. DAX'ом владею пока только поверхностно)  
Вывести в таблицу изменение в % к тому же периоду предыдущего года, DAX в PowerBI
 
Большое Вам спасибо! Сейчас применю
С именами таблиц понятно, указывать не буду, своего мнения по этому поводу ещё не появилось, поэтому указывал максимально точно. CALENDARAUTO не создал только в этот раз, понятно, что он обязателен. Спасибо ещё раз. Буду осваивать.  
Вывести в таблицу изменение в % к тому же периоду предыдущего года, DAX в PowerBI
 

Коллеги, добрый день,

Направьте пож-та в нужное направление:

В таблице PowerBI не могу (или не знаю как) получить колонку уровня изменения показателя к периоду предыдущего года. Ещё этот показатель называется Отклонение.

Делал следующее:

- Создал меру ПродажиГодНазад = CALCULATE([ВыручкаФакт];SAMEPERIODLASTYEAR('ПродажиФакт'[Дата]))

- Создал меру Динамика = DIVIDE('ПродажиФакт'[ВыручкаФакт]-[ПродажиГодНазад]; [ПродажиГодНазад]; BLANK())

- Получил только корректное итоговое  значение выручки тек. года к предыдущему 100,25% (при помещении меры в таблицу в месяцам - таблица падает)  

Проблема - не могу применить показатель 'изменение' в таблице, или что-то делаю не так. Попытки настроить 'Итоги по' без успеха; дополнительные вычисления не предусмотрены. Буду рад любому совету

Изменено: Дмитрий Марков - 3 Авг 2018 17:59:51
Перестали работать чекбоксы Activex
 
Большое спасибо! Думал, это не мой случай, достаточно давний кейс, у меня чекбоксы нормально были вставлены и работали(W10x64, Excel 2016). Пойду тогда по этому пути. Большое Вам спасибо!  
Перестали работать чекбоксы Activex
 
Перестали работать чекбоксы Activex. Лист не защищен, связанные ячейки назначены
Ни одного ответа нигде не нашел...
Можно ли объединить неск. макросов Worksheet_Change в один?, когда каждый может действовать для своего диапазона
 
PS: но перестал работать суперфильтр VBA (наверное, т.к. процедура идет теперь после процедуры вставки комментов)  
Можно ли объединить неск. макросов Worksheet_Change в один?, когда каждый может действовать для своего диапазона
 
Игорь, большое Вам спасибо.

При комментировании № 87 (Dim cell As Range) комменты не писались. Поменял очередность процедур - заработало без комментирования Dim cell As Range.
Спасибо.
Изменено: Дмитрий Марков - 14 Сен 2017 16:20:40
Можно ли объединить неск. макросов Worksheet_Change в один?, когда каждый может действовать для своего диапазона
 
Спасибо. Вот они... пока не особо изящно, но понемногу получается...
Код
Private Sub Worksheet_Change(ByVal Target As Range)
   On Error Resume Next
   If Target.Cells.Count > 1 Then Exit Sub
   If Not Intersect(Target, Range("J5:J15005")) Is Nothing Then
       If Len(Target) = 11 Then
           Target.NumberFormat = "[<=9999999]###-##-##;# (###) ###-##-##"
       ElseIf Len(Target) = 10 Then
           Target.NumberFormat = "[<=9999999]###-##-##;8 (###) ###-##-##"
       ElseIf Len(Target) = 9 Then
           Target.NumberFormat = "[<=9999999]##-##-##;8 (0###) ##-##-##"
       End If
   End If
   If Target.Cells.Count > 1 Then Exit Sub
   If Not Intersect(Target, Range("L5:L15005")) Is Nothing Then
       If Len(Target) = 11 Then
           Target.NumberFormat = "[<=9999999]###-##-##;# (###) ###-##-##"
       ElseIf Len(Target) = 10 Then
           Target.NumberFormat = "[<=9999999]###-##-##;8 (###) ###-##-##"
       ElseIf Len(Target) = 9 Then
           Target.NumberFormat = "[<=9999999]##-##-##;8 (0###) ##-##-##"
       End If
   End If
'____________________________________________________
    
    Dim FilterCol As Integer
    Dim FilterRange As Range
    Dim CondtitionString As Variant
    Dim Condition1 As String, Condition2 As String
 
    If Intersect(Target, Range("A2:AA2")) Is Nothing Then Exit Sub
 
    On Error Resume Next
    Application.ScreenUpdating = False
     
    'определяем диапазон данных списка
    Set FilterRange = Target.Parent.AutoFilter.Range
     
    'считываем условия из всех измененных ячеек диапазона условий
    For Each cell In Target.Cells
        FilterCol = cell.Column - FilterRange.Columns(1).Column + 1
         
        If IsEmpty(cell) Then
            Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol
        Else
            If InStr(1, UCase(cell.Value), " ИЛИ ") > 0 Then
                LogicOperator = xlOr
                ConditionArray = Split(UCase(cell.Value), " ИЛИ ")
            Else
                If InStr(1, UCase(cell.Value), " И ") > 0 Then
                    LogicOperator = xlAnd
                    ConditionArray = Split(UCase(cell.Value), " И ")
                Else
                    ConditionArray = Array(cell.Text)
                End If
            End If
            'формируем первое условие
            If Left(ConditionArray(0), 1) = "<" Or Left(ConditionArray(0), 1) = ">" Then
                Condition1 = ConditionArray(0)
            Else
                Condition1 = "=" & ConditionArray(0)
            End If
            'формируем второе условие - если оно есть
            If UBound(ConditionArray) = 1 Then
                If Left(ConditionArray(1), 1) = "<" Or Left(ConditionArray(1), 1) = ">" Then
                    Condition2 = ConditionArray(1)
                Else
                    Condition2 = "=" & ConditionArray(1)
                End If
            End If
            'включаем фильтрацию
            If UBound(ConditionArray) = 0 Then
                Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol, Criteria1:=Condition1
            Else
                Target.Parent.Range(FilterRange.Address).AutoFilter Field:=FilterCol, Criteria1:=Condition1, _
                    Operator:=LogicOperator, Criteria2:=Condition2
            End If
        End If
    Next cell
     
    Set FilterRange = Nothing
    Application.ScreenUpdating = True

'____________________________________________________


Dim NewCellValue$, OldComment$
Dim cell As Range
     
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("A5:AA15005")) Is Nothing Then Exit Sub
     
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("A5:AA15005"))
        If IsEmpty(cell) Then
            NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки
        Else
            NewCellValue = cell.Formula     'или ее содержимое
        End If
        On Error Resume Next
         
        With cell
            OldComment = .Comment.Text & Chr(10)
            .Comment.Delete     'удаляем старое примечание (если было)
            .AddComment         'добавляем новое и вводим в него текст
            .Comment.Text Text:=OldComment & Application.UserName & " " & _
                            Format(Now, "MM.DD.YY h:MM:ss") & " : " & NewCellValue
            .Comment.Shape.TextFrame.AutoSize = True    'делаем автоподбор размера
            .Comment.Shape.TextFrame.Characters.Font.Size = 8
        End With
    Next cell

End Sub
Страницы: 1 2 3 След.
Наверх