Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 След.
Заполнение таблицы значениями подходящими под условие.
 
Ну если заработало - значит правильно... Только надо иметь ввиду, то, что данные во вкладке "Расход" постоянно перезаписываются без удаления старых данных.
Изменено: vikttur - 23.06.2021 12:45:55
При изменении в одной из группы ячеек менять значения в других ячейках
 
При смене третей ячейки меняется первая.
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Not IsNumeric(Target.Value) Or Target.Value = "" Then
            Exit Sub
        End If
    Else
        Exit Sub
    End If
    Application.EnableEvents = False
    If Target.Column = 2 Then
        Cells(Target.Row, Target.Column + 2) = Cells(Target.Row, Target.Column) + Cells(Target.Row, Target.Column + 1)
    Else
        If Target.Column = 3 Then
            Cells(Target.Row, Target.Column + 1) = Cells(Target.Row, Target.Column - 1) + Cells(Target.Row, Target.Column)
        Else
            If Target.Column = 4 Then
                Cells(Target.Row, Target.Column - 2) = Cells(Target.Row, Target.Column) - Cells(Target.Row, Target.Column - 1)
            End If
        End If
    End If
    Application.EnableEvents = True
End Sub
Заменить первую цифру после буквы
 
Добрый день.
Вы случайно цифры и числа не путаете? Сделайте файл с несколькими примерами что есть и что должно быть.
Создать папку с подпапками для каждого файла
 
Протестировал, теперь работает.
Создать папку с подпапками для каждого файла
 
Поправил.
Создать папку с подпапками для каждого файла
 
Код
Sub temp()
    Application.DisplayAlerts = False
    For i = 6 To Cells(Rows.Count, 2).End(xlUp).Row
    Range("F" & i).FormulaR1C1 = "=MID(RC[-3],1,LEN(RC[-3])-4)"
    Path = Cells(i, 6).Value
    MkDir Path
    Path = Path & "\photo"
    MkDir Path
        FileCopy Cells(i, 3).Value, Path & "\" & Cells(i, 2).Value
    Next
    Application.DisplayAlerts = True
End Sub



Не проверял, но вроде так.
Изменено: vokilook - 22.06.2021 17:58:42
Заполнение таблицы значениями подходящими под условие.
 
Добавил кнопку.
Изменено: vikttur - 23.06.2021 10:41:02
Условное форматирование текста при определенных условиях.
 
Тогда так...
Последовательный выбор всех значений по условию
 
Последовательный выбор всех значений по условию?
Код
=ИНДЕКС($B$2:$B$25;ПОИСКПОЗ(G2;$A$2:$A$25;0)+СЧЁТЕСЛИ(G$1:$G2;G2)-1)
Изменено: vokilook - 22.06.2021 17:28:32
Заполнение таблицы значениями подходящими под условие.
 
Код
Option Explicit
Sub CopyIf()
    With ActiveWorkbook.Sheets("Приходы")
        Dim lrow, i, j As Long
        lrow = .Cells(Rows.Count, 7).End(xlUp).Row
        j = 2
        For i = 2 To lrow
            If .Range("G" & i) = "Терминал" Or .Range("G" & i) = "Расрочка\кредит" Then
                .Range("G" & i).EntireRow.Copy ActiveWorkbook.Sheets("Расход").Range("A" & j)
                j = j + 1
            End If
        Next i
    End With
End Sub

Изменено: vokilook - 22.06.2021 15:35:50
Условное форматирование текста при определенных условиях.
 
С доп столбцом подойдет?
Вставить нужный текст в ячейки через определенное количество строк.
 
Код
Option Explicit
Sub AddAdvertising()
    Const MAX_ADV As Integer = 3
    Dim i As Long, rnd As Integer
    With ActiveWorkbook.Sheets("Лист1")
        rnd = MAX_ADV
        For i = .Cells(Rows.Count, 1).End(xlUp).Row + 2 To 10 Step -1
            If i Mod 15 = 2 Then
                .Rows(i).Insert Shift:=xlDown
                .Rows(i).Insert Shift:=xlDown
                .Rows(i).Insert Shift:=xlDown
                .Range("A" & i) = "#EXTINF:0,audio-" & rnd & ".mp3"
                .Range("A" & i + 1) = "audio-" & rnd & ".mp3"
                If rnd = 1 Then
                    rnd = MAX_ADV
                Else
                    rnd = rnd - 1
                End If
            End If
        Next i
        
    End With
End Sub
Перенести даты из столбца в строку напротив ФИО работника
 
Код
Sub Макрос1()
Dim i As Long, lr As Long, x As Long, x2 As Long, n As Long, k As Long
Dim flag As Boolean
flag = True
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    lvl = Rows(i).OutlineLevel
    If lvl = 3 Then
        colmn = 4
        For n = i + 1 To lr
            lvl2 = Rows(n).OutlineLevel
            If flag And Rows(n + 1).OutlineLevel <> 4 Then
                Rows(n + 1).Insert Shift:=xlDown
                flag = False
            Else
                flag = False
            End If
            If lvl2 = 4 Then
                Cells(i, colmn) = Cells(n, 1)
                Cells(i + 1, colmn) = Cells(n, 2)
                Cells(i + 2, colmn) = Cells(n, 3)
                colmn = colmn + 1
            Else
                i = n - 1
                Exit For
            End If
        Next n
    End If
    flag = True
Next i
End Sub

Сортировка данных, полученных с помощью формулы
 
Вроде работает...
Перенести даты из столбца в строку напротив ФИО работника
 
Можете в примере заполнить строки с 19 по 22, как там должно быть?
Перенести даты из столбца в строку напротив ФИО работника
 
А как быть в строке 19 и 21?
Копирование строк по условию
 
Если из вкладки "Приложение 1" удалить белые строки, получится "Лист 1". "Лист 2" отсутствует. Что Вам нужно добавить то?
Подсчитать продолжительность рекламы в каждом часе
 
Да, условие не совсем понятное. Может так?
Как применить интервальный поиск для расчета KPI
 
Код
=ЕСЛИ(E6<80%;0;ЕСЛИ(И(E6>=80%;E6<100%);B6;ЕСЛИ(И(E6>=100%;E6<120%);C6;ЕСЛИ(E6>=120%;D6))))
Частота встречаемости продуктов в заказах
 
Код
Option Explicit
Sub FindRepeats()
    Dim numberOfPNs As Integer
    ' ----------------------------------------------------
    numberOfPNs = 3                 '  Задать кол-во артикулов (max = 6)
    ' ----------------------------------------------------
    Dim lrow As Long
    Dim dicOrders
    Set dicOrders = CreateObject("Scripting.Dictionary")
    lrow = Cells(Rows.Count, 7).End(xlUp).Row
    If lrow > 1 Then
        Range("G2:H" & lrow).Clear
    End If
    Dim colGoods As Collection
    Dim c_ As Variant
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    '  Формируем словарь заказов
    For Each c_ In Range("A2:A" & lrow)
        If dicOrders.exists(c_.Value) Then
            dicOrders(c_.Value).Add Range("B" & c_.Row).Value
        Else
            Set colGoods = New Collection
            colGoods.Add Range("B" & c_.Row).Value
            dicOrders.Add c_.Value, colGoods
        End If
    Next c_

    Dim dicPNs
    Set dicPNs = CreateObject("Scripting.Dictionary")
    Dim colPNs As New Collection
    Dim i As Integer
    '  Удаляем заказы с 1 товаром
    '  Формируем коллекцию артикулов
    For i = dicOrders.Count - 1 To 0 Step -1
        If dicOrders.Items()(i).Count < numberOfPNs Then
            dicOrders.Remove dicOrders.Keys()(i)
        Else
            On Error Resume Next
            Dim pn_ As Variant
            For Each pn_ In dicOrders.Items()(i)
                colPNs.Add pn_, pn_
            Next pn_
            On Error GoTo 0
        End If
    Next i
    
    Dim j, k, l, m, n As Integer
    Dim order_ As Variant
    '  Ищем повторения
    For Each order_ In dicOrders.Items()
        For i = 1 To order_.Count
            For j = i + 1 To order_.Count
            For k = j + 1 To order_.Count                                                    '  для трех
'            For l = k + 1 To order_.Count                                                   '  для четырех
'            For m = l + 1 To order_.Count                                                   '  для пяти
'            For n = m + 1 To order_.Count                                                   '  для шести
                Dim combPN As String
                combPN = order_.Item(i) & " + " & order_.Item(j)
                combPN = combPN & " + " & order_.Item(k)                                    '  для трех
'                combPN = combPN & " + " & order_.Item(l)                                   '  для четырех
'                combPN = combPN & " + " & order_.Item(m)                                   '  для пяти
'                combPN = combPN & " + " & order_.Item(n)                                   '  для шести
                dicPNs(combPN) = dicPNs(combPN) + 1
'            Next n                                                                         '  для шести
'            Next m                                                                         '  для пяти
'            Next l                                                                         '  для четырех
            Next k                                                                          '  для трех
            Next j
        Next i
    Next order_
    '  Выводим кол-во повторений для артикулов
    For i = 0 To dicPNs.Count - 1
        Range("G" & (i + 2)) = dicPNs.Keys()(i)
        Range("H" & (i + 2)) = dicPNs.Items()(i)
    Next i
End Sub

Указываем кол-во артикулов:
Код
    ' ----------------------------------------------------
    numberOfPNs = 3                 '  Задать кол-во артикулов (max = 6)
    ' ----------------------------------------------------
А потом снимаем/устанавливаем комментарии для нужных строк:
Код
            For k = j + 1 To order_.Count                                                    '  для трех
'            For l = k + 1 To order_.Count                                                   '  для четырех
'            For m = l + 1 To order_.Count                                                   '  для пяти
'            For n = m + 1 To order_.Count                                                   '  для шести
                Dim combPN As String
                combPN = order_.Item(i) & " + " & order_.Item(j)
                combPN = combPN & " + " & order_.Item(k)                                    '  для трех
'                combPN = combPN & " + " & order_.Item(l)                                   '  для четырех
'                combPN = combPN & " + " & order_.Item(m)                                   '  для пяти
'                combPN = combPN & " + " & order_.Item(n)                                   '  для шести
                dicPNs(combPN) = dicPNs(combPN) + 1
'            Next n                                                                         '  для шести
'            Next m                                                                         '  для пяти
'            Next l                                                                         '  для четырех
            Next k                                                                          '  для трех
Частота встречаемости продуктов в заказах
 
Код
Option Explicit
Sub FindRepeats()
    Dim lrow As Long
    Dim dicOrders
    Set dicOrders = CreateObject("Scripting.Dictionary")
    lrow = Cells(Rows.Count, 7).End(xlUp).Row
    If lrow > 1 Then
        Range("G2:G" & lrow).Clear
    End If
    Dim colGoods As Collection
    Dim c_ As Variant
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    '  Формируем словарь заказов
    For Each c_ In Range("A2:A" & lrow)
        If dicOrders.exists(c_.Value) Then
            dicOrders(c_.Value).Add Range("B" & c_.Row).Value
        Else
            Set colGoods = New Collection
            colGoods.Add Range("B" & c_.Row).Value
            dicOrders.Add c_.Value, colGoods
        End If
    Next c_

    Dim dicPNs
    Set dicPNs = CreateObject("Scripting.Dictionary")
    Dim colPNs As New Collection
    Dim i As Integer
    '  Удаляем заказы с 1 товаром
    '  Формируем коллекцию артикулов
    For i = dicOrders.Count - 1 To 0 Step -1
        If dicOrders.items()(i).Count = 1 Then
            dicOrders.Remove dicOrders.keys()(i)
        Else
            On Error Resume Next
            Dim pn_ As Variant
            For Each pn_ In dicOrders.items()(i)
                colPNs.Add pn_, pn_
            Next pn_
            On Error GoTo 0
        End If
    Next i
    
    Dim j As Integer
    Dim order_ As Variant
    '  Ищем повторения
    For Each order_ In dicOrders.items()
        For i = 1 To order_.Count
            For j = i + 1 To order_.Count
                Dim combPN As String
                combPN = order_.Item(i) & " + " & order_.Item(j)
                dicPNs(combPN) = dicPNs(combPN) + 1
            Next j
        Next i
    Next order_
    '  Выводим кол-во повторений для артикулов
    For i = 0 To dicPNs.Count - 1
        Range("G" & (i + 2)) = dicPNs.keys()(i)
        Range("H" & (i + 2)) = dicPNs.items()(i)
    Next i
End Sub

Поправил, в соответствии с задачей. Сначала не разобрался...
Изменено: vokilook - 10.06.2021 17:19:38
Введенное значение подставлять в определенный лист по размеру и дате
 
Добрый день.

Можно, например вот таким образом. Изменяете значение ячейки G5 на лист3 - меняется соответствующая (ФИО, дата, форма) ячейка.
Изменено: vokilook - 29.07.2020 12:31:52
VBA. Замена Индекс Поискпоз макросами с использованием формулы, массивов,словаря
 
Добрый день.

Вариант реализации со словарем.
Предварительно необходимо подключить Microsoft Scripting Runtime
Скрытый текст
Код
Option Explicit
Sub SearchMatch()
    Dim dicData As New Dictionary
    Dim arrSource As Variant
    arrSource = Sheets("All").Range("C2" & ":D" & Cells(Rows.Count, 1).End(xlUp).Row)
    
    Dim i As Long
    For i = LBound(arrSource) To UBound(arrSource)
        dicData.Add arrSource(i, 2), arrSource(i, 1)
    Next i
    
    Dim arrSearch As Variant
    arrSearch = Sheets("Поиск").Range("A2" & ":A" & Cells(Rows.Count, 1).End(xlUp).Row)
    For i = LBound(arrSearch) To UBound(arrSearch)
        If dicData.Exists(arrSearch(i, 1)) Then
            Sheets("Поиск").Cells(i + 1, 2) = dicData(arrSearch(i, 1))
        Else
            Sheets("Поиск").Cells(i + 1, 2) = "Ошибка"
        End If
    Next i
    
End Sub

Изменено: vokilook - 28.07.2020 14:26:24 (Option explicit)
Вставить данные из одной ячейки в другую с текстом после первого переноса строки
 
Добрый день.
Вставить в строку с проверкой данных без форматирования.
 
Цитата
Stalevar написал:
"Задача вставить из буфера обмена в одну строку только цифры и без форматирования"
Изменено: vokilook - 27.07.2020 16:53:58
Вставить в строку с проверкой данных без форматирования.
 
Добрый день.

Stalevar, для информации https://ru.wikipedia.org/wiki/%D0%A6%D0%B8%D1%84%D1%80%D1%8B
Изменено: vokilook - 27.07.2020 14:29:13
Подсчет суммы в выбираемом диапазоне при наличии нескольких условий, Подсчитать плановые суммы продаж автомобилей каждой марки за выбранный промежуток времени
 
А, да, текст в диапазон не попадает. Гениально. Спасибо еще раз.
Подсчет суммы в выбираемом диапазоне при наличии нескольких условий, Подсчитать плановые суммы продаж автомобилей каждой марки за выбранный промежуток времени
 
Ух ты как оперативно. Спасибо большое. Я вот только не могу понять почему он квартальные цифры игнорирует?
Подсчет суммы в выбираемом диапазоне при наличии нескольких условий, Подсчитать плановые суммы продаж автомобилей каждой марки за выбранный промежуток времени
 
Добрый день.

Задача условно такая. Нужно подсчитать план по продажам автомобилей определенного производителя и марки и вывести данные в Свод.
Я смог придумать как посчитать сумму за конкретный период. Не могу сделать так, чтобы при выборе начала и окончания периода, суммы соответствующим образом пересчитывались.

Прошу помощи.
Указывать дату, в зависимости от времени печати документа
 
Если я правильно понял...
Код
=ЕСЛИ(И((Лист2!F2-Лист2!F28)>ВРЕМЗНАЧ("20:00");ЧАС(ТДАТА())<=20);СЕГОДНЯ()-1;ЕСЛИ(И((Лист2!F2-Лист2!F28)<=ВРЕМЗНАЧ("20:00");ЧАС(ТДАТА())>20);СЕГОДНЯ()+1;СЕГОДНЯ()))
Страницы: 1 2 След.
Наверх