Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » Msi2102
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 145 След.
Сравнение даты в ячейке с текущим годом
 
#
26.02.2026 14:35:28
Цитата
milet написал:
Слишком сложно думал.
Только Вы учтите, что на самом деле, даты никуда не делись их просто не видно на листе
 
Перейти    
Сравнение даты в ячейке с текущим годом
 
#
26.02.2026 14:14:55
Вот так, в таблице ячейки не пустые
 
Перейти    
Сравнение даты в ячейке с текущим годом
 
#
26.02.2026 14:11:47
Цитата
milet написал:
Вы немного не поняли.
Если бы Вы читали правила, особенно про файл с примером, тогда может было-бы понятнее
 
Перейти    
Сравнение даты в ячейке с текущим годом
 
#
26.02.2026 14:08:39
Отфильтруйте по году и удалите ненужные или макросом, можно ещё Условным форматированием но тогда Вы просто скроете дату, а не удалите
Изменено: Msi2102 - 26.02.2026 14:12:50
 
Перейти    
Распределение по столбцам., Необходимо распределить артикулы согласно индексам.
 
#
25.02.2026 18:24:37
Цитата
МатросНаЗебре написал:
Добавил форматирование диапазонов
тоже добавил немного позитивчика
Код
Sub Макрос1()
    arr = Range("A2:AX" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    For n = 1 To UBound(arr)
        arr(n, 50) = arr(n, 47) & arr(n, 49) & arr(n, 48)
    Next
    Sort_Array arr, 50
    Set sd = CreateObject("Scripting.Dictionary")
    For n = 1 To UBound(arr)
        If Not sd.Exists(arr(n, 1)) Then Set sd(arr(n, 1)) = CreateObject("Scripting.Dictionary"): m = m + 1
        If Not sd(arr(n, 1)).Exists(arr(n, 47) & "|" & arr(n, 49)) Then Set sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49)) = CreateObject("Scripting.Dictionary")
        If Not sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49)).Exists(arr(n, 48)) Then Set sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)) = CreateObject("Scripting.Dictionary")
        If Not sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)).Exists(arr(n, 4)) Then sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)).Add arr(n, 4), arr(n, 4): m = m + 1
    Next
    ReDim arr_rez(1 To m, 1 To 5)
    n = 1
    For Each y In sd
        arr_rez(n, 1) = y
        n = n + 1
        okr_zag = okr_zag & "|A" & n & ":E" & n
        For Each y1 In sd(y)
            k_max = 0
            p = ""
            For Each y2 In sd(y)(y1)
                If p <> y2 Then p = y2: k = 0
                For Each y3 In sd(y)(y1)(y2)
                    arr_rez(n + k, 1) = Split(y1, "|")(0)
                    arr_rez(n + k, 2) = Split(y1, "|")(1)
                    If y2 = "X" Then arr_rez(n + k, 3) = sd(y)(y1)(y2)(y3)
                    If y2 = "Y" Then arr_rez(n + k, 4) = sd(y)(y1)(y2)(y3)
                    If y2 = "Z" Then arr_rez(n + k, 5) = sd(y)(y1)(y2)(y3)
                    k = k + 1
                Next
                If k_max < k Then k_max = k
            Next
            okr = okr & "|A" & n + 1
            n = n + k_max
            okr = okr & ":E" & n
        Next
    Next
    With Worksheets("Результат")
        .Range("A2:E" & Cells(Rows.Count, 1).End(xlUp).Row).Clear ' = ""
        .Range("A2").Resize(UBound(arr_rez), 5) = arr_rez
        .Activate
        arr_okr = Split(Mid(okr, 2), "|")
        For Each y In arr_okr
            If n = 1 Then
                .Range(y).Interior.Color = 6737151
                n = 0
            Else
                .Range(y).Interior.Color = 10092543
                n = 1
            End If
        Next
        arr_okr = Split(Mid(okr_zag, 2), "|")
        For Each y In arr_okr
            .Range(y).Interior.Color = 6724095
        Next
    End With
End Sub
Function Sort_Array(arr As Variant, n As Integer)
    Dim i As Long, j As Long, temp As Variant
    For i = LBound(arr, 1) To UBound(arr, 1) - 1
        For j = i + 1 To UBound(arr, 1)
            If arr(i, n) > arr(j, n) Then
                For col = LBound(arr, 2) To UBound(arr, 2)
                    temp = arr(i, col)
                    arr(i, col) = arr(j, col)
                    arr(j, col) = temp
                Next col
            End If
        Next j
    Next i
    Sort_Array = arr
End Function
 
Перейти    
Распределение по столбцам., Необходимо распределить артикулы согласно индексам.
 
#
25.02.2026 17:05:05
МатросНаЗебре, Ошибочка вышла, как и писал выше
 
Перейти    
Распределение по столбцам., Необходимо распределить артикулы согласно индексам.
 
#
25.02.2026 15:12:12
МатросНаЗебре, Привет, а можешь приложить файл, а то у меня с тобой разные результаты получаются, например
АВС 4 кв - A
Индекс Х-Х 4 кв - D
XYZ 4 кв. 2025 - X
количество - 4 шт., а у тебя получается 1 шт.
 
Перейти    
Выбор последнего статуса по ID, Задача: получить последнее значение статуса ID для всех ID.
 
#
25.02.2026 08:59:48
Цитата
met.constr написал:
Подскажите какое нибудь простое и эффективное решение.
Кроме формул ещё сортировка, фильтры, макросы, PQ. И желательно знать какой у Вас офис
Изменено: Msi2102 - 25.02.2026 09:01:04
 
Перейти    
Распределение по столбцам., Необходимо распределить артикулы согласно индексам.
 
#
24.02.2026 21:02:35
Ещё вариант макросом
Код
Sub Макрос1()
    arr = Range("A2:AX" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    For n = 1 To UBound(arr)
        arr(n, 50) = arr(n, 47) & arr(n, 49) & arr(n, 48)
    Next
    Sort_Array arr, 50
    Set sd = CreateObject("Scripting.Dictionary")
    For n = 1 To UBound(arr)
        If Not sd.Exists(arr(n, 1)) Then Set sd(arr(n, 1)) = CreateObject("Scripting.Dictionary"): m = m + 1
        If Not sd(arr(n, 1)).Exists(arr(n, 47) & "|" & arr(n, 49)) Then Set sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49)) = CreateObject("Scripting.Dictionary")
        If Not sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49)).Exists(arr(n, 48)) Then Set sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)) = CreateObject("Scripting.Dictionary")
        If Not sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)).Exists(arr(n, 4)) Then sd(arr(n, 1))(arr(n, 47) & "|" & arr(n, 49))(arr(n, 48)).Add arr(n, 4), arr(n, 4): m = m + 1
    Next
    ReDim arr_rez(1 To m, 1 To 5)
    n = 1
    For Each y In sd
        arr_rez(n, 1) = y
        n = n + 1
        For Each y1 In sd(y)
            k_max = 0
            p = ""
            For Each y2 In sd(y)(y1)
                If p <> y2 Then p = y2: k = 0
                For Each y3 In sd(y)(y1)(y2)
                    arr_rez(n + k, 1) = Split(y1, "|")(0)
                    arr_rez(n + k, 2) = Split(y1, "|")(1)
                    If y2 = "X" Then arr_rez(n + k, 3) = sd(y)(y1)(y2)(y3)
                    If y2 = "Y" Then arr_rez(n + k, 4) = sd(y)(y1)(y2)(y3)
                    If y2 = "Z" Then arr_rez(n + k, 5) = sd(y)(y1)(y2)(y3)
                    k = k + 1
                Next
                If k_max < k Then k_max = k
            Next
            n = n + k_max
        Next
    Next
    With Worksheets("Результат")
        .Range("A2:E" & Cells(Rows.Count, 1).End(xlUp).Row).Clear ' = ""
        .Range("A2").Resize(UBound(arr_rez), 5) = arr_rez
        .Activate
    End With
End Sub
Function Sort_Array(arr As Variant, n As Integer)
    Dim i As Long, j As Long, temp As Variant
    For i = LBound(arr, 1) To UBound(arr, 1) - 1
        For j = i + 1 To UBound(arr, 1)
            If arr(i, n) > arr(j, n) Then
                For col = LBound(arr, 2) To UBound(arr, 2)
                    temp = arr(i, col)
                    arr(i, col) = arr(j, col)
                    arr(j, col) = temp
                Next col
            End If
        Next j
    Next i
    Sort_Array = arr
End Function
Изменено: Msi2102 - 25.02.2026 08:58:05
 
Перейти    
Как многоблочную таблицу преобразовать в одноблочную?
 
#
24.02.2026 13:53:22
Ещё вариант PQ
Код
let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    Фильтр = Table.SelectRows(Источник, each ([Столбец1] <> null)),
    Столбецы = Table.Buffer(Table.FromRows(List.Split(List.Combine(Table.ToRows(Фильтр)), 4), {"Столбец1", "Столбец2", "Столбец3", "Столбец4"})),
    Группа = Table.Group (
        Столбецы,
            {"Столбец1"},
            {{
                "Количество",
                (t) =>
                [sort = Table.Sort(t,  {{"Столбец2", Order.Ascending}}), 
                rez = if sort[Столбец2]{1} = 1 then Table.Combine({Table.RemoveFirstN(sort, 1), Table.FirstN(sort, 1)}) else sort][rez]
            }}
        ),
    Развернуть = Table.Combine (Группа[Количество])
in
    Развернуть
Изменено: Msi2102 - 24.02.2026 14:07:53
 
Перейти    
Объединение в 1 строку
 
#
24.02.2026 11:07:17
Ни чего не понял из Вашего объяснения, если нужно собрать все Кросс-артикулы яблок, персиков и груш, то попробуйте так (массивная):
Код
=ОБЪЕДИНИТЬ("; ";1;ЕСЛИ(--($A$2:$A$16=$A2)=1;$C$2:$C$16;""))
 
Перейти    
Из одного списка сделать несколько, несколько списков от большего к меньшему
 
#
20.02.2026 10:20:17
Цитата
foller написал:
в частности на подгруппу по 5 фамилий
Принцип-то какой разбития на подгруппы? Понятно, что по возрастанию, но через одного или ещё как?
Изменено: Msi2102 - 20.02.2026 10:26:50
 
Перейти    
Дубликаты внутри ячейки без разделителей, Дубликаты внутри ячейки без разделителей, надо как-то удалить дубли
 
#
20.02.2026 09:30:32
Цитата
sotnikov написал:
Добавил выше 3 вариант,
Да теперь всё сошлось
PS: нашел как тебя сломать: AF11610024CAF1161002-4C или так AF10347114AF1AF10347114AF1, а первый и второй варианты работают почти правильно, а вот третий совсем подкачал :D
Изменено: Msi2102 - 20.02.2026 10:21:17
 
Перейти    
Дубликаты внутри ячейки без разделителей, Дубликаты внутри ячейки без разделителей, надо как-то удалить дубли
 
#
19.02.2026 19:47:02
Переделал на макрос, до 4 повторов. Думает долго, но зато потом не будет тупить, собственно RegExp всегда был долгим. Убавил базу

Код
Sub Замена_дублей()
    Dim ptrn As String, txt1 As String, n As Long
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    arr = Range("A2:A" & lr)
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True
    For m = 1 To UBound(arr)
        txt = arr(m, 1)
        txt1 = Replace(Replace(Replace(txt, ".", "\."), " ", ""), "-", "")
        ptrn = ""
        For n = 1 To Len(txt1)
            ptrn = ptrn & Mid(txt1, n, 1) & " *-? *"
        Next n
        For n = 4 To 1 Step -1
            txt1 = ""
            objRegExp.Pattern = Left(ptrn, Len(ptrn) / n)
            Set objMatches = objRegExp.Execute(txt)
            For i = 0 To objMatches.Count - 1
                txt1 = txt1 & objMatches.Item(i).Value
            Next
            If Trim(txt1) = Trim(txt) Then arr(m, 1) = Trim(objMatches.Item(0).Value): Exit For
        Next
    Next
    Range("B2:B" & lr) = arr
End Sub
 
Перейти    
Дубликаты внутри ячейки без разделителей, Дубликаты внутри ячейки без разделителей, надо как-то удалить дубли
 
#
19.02.2026 16:19:02
sotnikov, Второй результат почти всё правильно, кроме строк Excel 1302; 1305; 1313
Изменено: Msi2102 - 19.02.2026 16:20:25
 
Перейти    
Дубликаты внутри ячейки без разделителей, Дубликаты внутри ячейки без разделителей, надо как-то удалить дубли
 
#
19.02.2026 16:04:40
Немного изменил паттерн
Код
Function Замена_дублей(txt As String) As String
    Dim ptrn As String, txt1 As String, n As Byte
    txt1 = Replace(Replace(Replace(txt, ".", "\."), " ", ""), "-", "")
    For n = 1 To Len(txt1)
        ptrn = ptrn & Mid(txt1, n, 1) & " *-? *"
    Next n
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True
    For n = 2 To 3
        objRegExp.Pattern = Left(ptrn, Len(ptrn) / n)
        If objRegExp.Execute(txt).Count > 1 Then txt = objRegExp.Execute(txt).Item(0).Value: Exit For
    Next
    Замена_дублей = Trim(txt) ' Оставлет все пробелы внутри наименования
'    Замена_дублей = WorksheetFunction.Trim(txt) 'Если нужно оставить только один пробел
End Function
Изменено: Msi2102 - 19.02.2026 16:26:19 (Опечатка в паттерне)
 
Перейти    
Дубликаты внутри ячейки без разделителей, Дубликаты внутри ячейки без разделителей, надо как-то удалить дубли
 
#
19.02.2026 15:27:34
Написал UDF немного подвисает на большом объеме, поэтому можете переделать просто в макрос
Код
Function Замена_дублей(txt As String) As String
    Dim ptrn As String, txt1 As String, n As Byte
    txt1 = Replace(Replace(Replace(txt, ".", ".\"), " ", ""), "-", "")
    For n = 1 To Len(txt1)
        ptrn = ptrn & Mid(txt1, n, 1) & " ?-?"
    Next n
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True
    For n = 2 To 3
        objRegExp.Pattern = Left(ptrn, Len(ptrn) / n)
        If objRegExp.Execute(txt).Count > 1 Then txt = objRegExp.Execute(txt).Item(0).Value: Exit For
    Next
    Замена_дублей = txt
End Function
Изменено: Msi2102 - 19.02.2026 15:52:03
 
Перейти    
Дубликаты внутри ячейки без разделителей, Дубликаты внутри ячейки без разделителей, надо как-то удалить дубли
 
#
19.02.2026 14:10:05
Цитата
ПавелW написал:
можно так попробовать:
Ну вот с тремя повторами вопрос закрыт, с пробелами думаю тоже не проблема, останется только дефис, но думаю тоже решаемо
 
Перейти    
Дубликаты внутри ячейки без разделителей, Дубликаты внутри ячейки без разделителей, надо как-то удалить дубли
 
#
19.02.2026 13:42:45
На скорую руку набросал
Код
=ЕСЛИ(ЛЕВСИМВ(A2;ДЛСТР(A2)/2)=ПРАВСИМВ(A2;ДЛСТР(A2)/2);ЛЕВСИМВ(A2;ДЛСТР(A2)/2);A2)


но у Вас есть такие строки
JTC-3309JTC-3309JTC-3309 - три повтора
  20A16MR 20A16MR - пробелы спереди
VR-50208VR50208 - вторая половина без дефиса
можно конечно ещё навоять условий, но думаю проще будет макросом
Изменено: Msi2102 - 19.02.2026 13:46:01
 
Перейти    
Как вытащить артикул из текста, Как вытащить артикул из текста
 
#
19.02.2026 08:56:26
Вот ещё вариант
Код
=ФИЛЬТР.XML("<t><s>"&ПОДСТАВИТЬ(A2;" ";"</s><s>")&"</s></t>";"//s[last()]")
 
Перейти    
Как найти максимальное значение времени
 
#
17.02.2026 16:41:59
А как так получилось, что у Вас 15.02.2026 Иванов вышел через Турникет №1 (19) в 17:38 и потом дважды зашел через Турникет №3 (21) в 18:15 и следом через Турникет №2 (27) в 18:39, и потом уже появился 16.02.2026 но тоже на вход, это должно как-то учитываться или это просто пример так составлен? По остальным сотрудникам тоже самое
Изменено: Msi2102 - 17.02.2026 16:45:27
 
Перейти    
Макрос сбор первого и последнего значения по дате
 
#
17.02.2026 14:29:57
Цитата
Evgeny772 написал:
Вообще я считаю количество часов в смене, от первого начала периода, до последнего конца периода, второе минус первое, написал я это просто для понимания общей картины.
Может пригодится, Макрос2 считает общее количество без разбивки дат, Макрос3 считает количество часов с учетом перехода 00:00:00, остаток прибавляет к следующему дню. Во втором столбце общее количество секунд
Скрытый текст
Изменено: Msi2102 - 17.02.2026 17:47:28 (заменил файл, добавил немного расчетов)
 
Перейти    
Макрос сбор первого и последнего значения по дате
 
#
17.02.2026 12:04:52
Я так и не понял, что именно Вы хотите посчитать, количество часов в сутки или количество часов в смену, тогда начало и конец смены, вначале просили просто начало и конец. Если нужно посчитать количество часов, то что делать с переходящим временем, разбивать или целиком в предыдущие сутки включать.
Если нужно только время
Цитата
Evgeny772 написал:
Имелось ввиду если 12.02 последний период закрылся после 00:00:00, то взять последнее встречающееся значение в столбце конец периода до 00:00:00, в данном случае 18:45:22
то как быть если будет всего одно включение которое переходит с одного дня на другой, по вашему рассуждению он не будет учитываться, например 13.02.2026 14:49:33, закончится не в 13.02.206 20:06:33 а 14.02.206 20:06:33
 
Перейти    
Макрос сбор первого и последнего значения по дате
 
#
17.02.2026 11:25:43
Цитата
Evgeny772 написал:
с такими днями думаю вручную разберусь
Посмотрите файл, так должно быть?
 
Перейти    
Макрос сбор первого и последнего значения по дате
 
#
17.02.2026 11:00:44
Не совсем понял, что именно вы хотите. Разбить даты? Например: начало 11.02.2026 13:06:03, конец 12.02.2026 12:42:49, чтобы разбились на две
начало 11.02.2026 13:06:03, конец 11.02.2026 23:59:59 и следующая начало 12.02.2026 00:00:00, конец 12.02.2026 12:42:49, тогда будет начало следующего дня начинаться не с 12.02.2026 13:37:25, а с 12.02.2026 00:00:00, или нужна последняя дата которая есть в таблице.
Могу ещё посоветовать разбить эти даты в начальной таблице

Немного отредактировал сводную, там видны эти даты
 
Перейти    
Макрос сбор первого и последнего значения по дате
 
#
17.02.2026 09:54:45
Ну если очень нужно макросом
Код
Sub Макрос1()
    arr_b = Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    Set sd = CreateObject("Scripting.Dictionary")
    For n = 1 To UBound(arr_b)
        If Not sd.Exists(CDate(arr_b(n, 1))) Then Set sd(CDate(arr_b(n, 1))) = CreateObject("Scripting.Dictionary"): m = m + 1
        If Not sd(CDate(arr_b(n, 1))).Exists("min") Then
            sd(CDate(arr_b(n, 1))).Add "min", CDate(arr_b(n, 2))
        Else
            If CDate(sd(CDate(arr_b(n, 1)))("min")) > CDate(arr_b(n, 2)) Then
                sd(CDate(arr_b(n, 1)))("min") = CDate(arr_b(n, 2))
            End If
        End If
        If Not sd(CDate(arr_b(n, 1))).Exists("max") Then
            sd(CDate(arr_b(n, 1))).Add "max", arr_b(n, 3) & " " & CDate(arr_b(n, 4))
        Else
            If CDate(sd(CDate(arr_b(n, 1)))("max")) < arr_b(n, 3) & " " & CDate(arr_b(n, 4)) Then
                sd(CDate(arr_b(n, 1)))("max") = arr_b(n, 3) & " " & CDate(arr_b(n, 4))
            End If
        End If
    Next
    ReDim arr_rez(1 To m, 1 To 4)
    n = 1
    For Each y In sd
        arr_rez(n, 1) = y
        arr_rez(n, 2) = Format(sd(y)("min"), "HH:mm:ss")
        arr_rez(n, 3) = CDate(Split(sd(y)("max"), " ")(0))
        arr_rez(n, 4) = Format(sd(y)("max"), "HH:mm:ss")
        n = n + 1
    Next
    [g2].Resize(UBound(arr_rez), 4) = arr_rez
End Sub

ps: Сразу не обратил внимания, что может начинаться одним днем, а заканчиваться другим. Поэтому примеры со сводной тоже не совсем корректны, хотя в них результат как на листе "Готовый пример"
Изменено: Msi2102 - 17.02.2026 10:39:56 (отредактировал макрос)
 
Перейти    
Макрос сбор первого и последнего значения по дате
 
#
17.02.2026 08:59:57
А просто сводная не пойдет
 
Перейти    
В Power Query выделить из столбца оценки и просуммировать их
 
#
16.02.2026 16:10:00
Попробуйте так, для данного примера без PQ
Код
=СУММПРОИЗВ(ПОДСТАВИТЬ(ФИЛЬТР.XML("<t><s>"&ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(H2;"ч";" ч");",";".");" ";"</s><s>")&"</s></t>";"//s[.*0=0]");".";",")*1)
Изменено: Msi2102 - 16.02.2026 16:33:38
 
Перейти    
Перенос данных макросом с одного листа на другой
 
#
13.02.2026 17:30:16
Помощь зала:
Перенос данных макросом с одного листа на другой
 
Перейти    
Перенос данных макросом с одного листа на другой
 
#
13.02.2026 17:14:51
Пробуйте
Код
Sub Макрос1()
    lr = Worksheets("Материалы").Cells(Rows.Count, 1).End(xlUp).Row
    arr_m = Worksheets("Материалы").Range("A2:G" & lr)
    n = WorksheetFunction.CountA(Worksheets("Материалы").Range("G2:G" & lr))
    If n = 0 Then MsgBox "Ничего не выбрвно": Exit Sub
    ReDim arr_z(1 To n, 1 To 4)
    m = 1
    For n = 1 To UBound(arr_m)
        If arr_m(n, 7) <> "" Then
            arr_z(m, 1) = arr_m(n, 1)
            arr_z(m, 2) = arr_m(n, 2)
            arr_z(m, 3) = arr_m(n, 6)
            arr_z(m, 4) = arr_m(n, 7)
            m = m + 1
        End If
    Next
    lr = Worksheets("Заказать").Cells(Rows.Count, 1).End(xlUp).Row
    If lr > 1 Then Worksheets("Заказать").Range("A2:D" & lr).ClearContents
    Worksheets("Заказать").Cells(2, 1).Resize(UBound(arr_z), UBound(arr_z, 2)) = arr_z
End Sub
 
Перейти    
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 145 След.
Наверх