Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Выполнение макроса только для строк с текущей датой - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выполнение макроса только для строк с текущей датой (Макросы/Sub)
Выполнение макроса только для строк с текущей датой
Vetya Дата: Пятница, 04.05.2018, 13:07 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Добрый день, Есть макрос сортировки строк таблицы по цветам, можно ли сделать так. чтобы сортировка срабатывала для строк добавленных в таблицу текущей даты, то-есть "сегодня", при этом все предыдущие строки оставались неизменными. Подскажите пожалуйста
[vba]
Код

Sub макрос6()
    
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "A2:A50"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(221 _
        , 217, 196)
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(218 _
        , 238, 243)
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(197 _
        , 217, 241)
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(235 _
        , 241, 222)
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(242 _
        , 220, 219)
    With ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
               .Apply
    End With
End Sub
[/vba]
 
Ответить
СообщениеДобрый день, Есть макрос сортировки строк таблицы по цветам, можно ли сделать так. чтобы сортировка срабатывала для строк добавленных в таблицу текущей даты, то-есть "сегодня", при этом все предыдущие строки оставались неизменными. Подскажите пожалуйста
[vba]
Код

Sub макрос6()
    
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "A2:A50"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(221 _
        , 217, 196)
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(218 _
        , 238, 243)
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(197 _
        , 217, 241)
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(235 _
        , 241, 222)
    ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort.SortFields.Add(Range("A2:A22" _
        ), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(242 _
        , 220, 219)
    With ActiveWorkbook.Worksheets("Лист2").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
               .Apply
    End With
End Sub
[/vba]

Автор - Vetya
Дата добавления - 04.05.2018 в 13:07
KuklP Дата: Пятница, 04.05.2018, 15:00 | Сообщение № 2
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Подсказываю. Можно.


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеПодсказываю. Можно.

Автор - KuklP
Дата добавления - 04.05.2018 в 15:00
Vetya Дата: Понедельник, 07.05.2018, 07:02 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Я понимаю, что можно и даже догадываюсь что это делается, вероятно, с помощью Type:=xlTimePeriod, DateOperator:=xlToday, но я совсем недавно с макросами и потратил пол дня добавляя то так, то сяк и так и не пришел к нужному результату :(
 
Ответить
СообщениеЯ понимаю, что можно и даже догадываюсь что это делается, вероятно, с помощью Type:=xlTimePeriod, DateOperator:=xlToday, но я совсем недавно с макросами и потратил пол дня добавляя то так, то сяк и так и не пришел к нужному результату :(

Автор - Vetya
Дата добавления - 07.05.2018 в 07:02
Nic70y Дата: Понедельник, 07.05.2018, 07:58 | Сообщение № 4
Группа: Друзья
Ранг: Экселист
Сообщений: 8704
Репутация: 2258 ±
Замечаний: 0% ±

Excel 2010
Я понимаю
по ходу нет
Подсказываю
файла Вашего нет,
а без него на чем проверять?


ЮMoney 41001841029809
 
Ответить
Сообщение
Я понимаю
по ходу нет
Подсказываю
файла Вашего нет,
а без него на чем проверять?

Автор - Nic70y
Дата добавления - 07.05.2018 в 07:58
Vetya Дата: Понедельник, 07.05.2018, 09:09 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Смог только разбив на 2 части архив.
К сообщению приложен файл: 111.part01.rar (99.0 Kb) · 111.part02.rar (72.6 Kb)
 
Ответить
СообщениеСмог только разбив на 2 части архив.

Автор - Vetya
Дата добавления - 07.05.2018 в 09:09
_Boroda_ Дата: Понедельник, 07.05.2018, 11:07 | Сообщение № 6
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Vetya, прочитайте уже наконец Правила форума. Там все написано. И для Вашего случая тоже
Второй архив пуст
В первом файл на 2,7 мега.

Держите Ваш файл, почищенный до 35кб.
Вставьте туда данные за сегодня так, как они будут там появляться до запуска макроса. А на новом листе вручную сделайте так, как нужно, чтобы было в итоге
К сообщению приложен файл: 111_56.xlsm (34.5 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеVetya, прочитайте уже наконец Правила форума. Там все написано. И для Вашего случая тоже
Второй архив пуст
В первом файл на 2,7 мега.

Держите Ваш файл, почищенный до 35кб.
Вставьте туда данные за сегодня так, как они будут там появляться до запуска макроса. А на новом листе вручную сделайте так, как нужно, чтобы было в итоге

Автор - _Boroda_
Дата добавления - 07.05.2018 в 11:07
Vetya Дата: Понедельник, 07.05.2018, 11:09 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Держите Ваш файл, почищенный до 35кб.

:o :o :o ничего себе я захламил
 
Ответить
Сообщение
Держите Ваш файл, почищенный до 35кб.

:o :o :o ничего себе я захламил

Автор - Vetya
Дата добавления - 07.05.2018 в 11:09
Vetya Дата: Понедельник, 07.05.2018, 11:36 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Во вложении файл,Лист2 (Итог) строка с дублями в первом столбце окрашиваются по цвету, пытался сделать так, чтобы "на сегодня" была автоматическая группировка (по времени) людей с одинаковыми ФИО\цветами. У меня получалось только так, что сортируется вся таблица целиком - а надо чтобы только "сегодня"
К сообщению приложен файл: 0141105.xlsm (65.9 Kb)
 
Ответить
СообщениеВо вложении файл,Лист2 (Итог) строка с дублями в первом столбце окрашиваются по цвету, пытался сделать так, чтобы "на сегодня" была автоматическая группировка (по времени) людей с одинаковыми ФИО\цветами. У меня получалось только так, что сортируется вся таблица целиком - а надо чтобы только "сегодня"

Автор - Vetya
Дата добавления - 07.05.2018 в 11:36
RAN Дата: Понедельник, 07.05.2018, 12:43 | Сообщение № 9
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
[vba]
Код
Sub Мяу()
    Dim r As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        .AutoFilter.Range.AutoFilter Field:=3, Operator:= _
                    xlFilterValues, Criteria2:=Array(2, Format(Date, "m\/d\/yyyy"))  '"5/7/2018")
        Set r = .AutoFilter.Range
        With .Sort
            .SortFields.Clear
            .SortFields.Add(r(1) _
          , xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
                          = RGB(197, 217, 241)
            .SortFields.Add(r(1) _
          , xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
                          = RGB(253, 233, 217)
            .SetRange r
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .AutoFilter.Range.AutoFilter Field:=3
    End With
    Application.ScreenUpdating = True
End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение[vba]
Код
Sub Мяу()
    Dim r As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        .AutoFilter.Range.AutoFilter Field:=3, Operator:= _
                    xlFilterValues, Criteria2:=Array(2, Format(Date, "m\/d\/yyyy"))  '"5/7/2018")
        Set r = .AutoFilter.Range
        With .Sort
            .SortFields.Clear
            .SortFields.Add(r(1) _
          , xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
                          = RGB(197, 217, 241)
            .SortFields.Add(r(1) _
          , xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
                          = RGB(253, 233, 217)
            .SetRange r
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .AutoFilter.Range.AutoFilter Field:=3
    End With
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - RAN
Дата добавления - 07.05.2018 в 12:43
Vetya Дата: Понедельник, 07.05.2018, 13:22 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
"Run-time error '91': Object variable or With block variable not set"
пробовал вместо ActiveSheet - ActiveWorkbook.Worksheets("Итог") воткнуть - таже беда
 
Ответить
Сообщение"Run-time error '91': Object variable or With block variable not set"
пробовал вместо ActiveSheet - ActiveWorkbook.Worksheets("Итог") воткнуть - таже беда

Автор - Vetya
Дата добавления - 07.05.2018 в 13:22
StoTisteg Дата: Понедельник, 07.05.2018, 13:23 | Сообщение № 11
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
На какую строку ругается?


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеНа какую строку ругается?

Автор - StoTisteg
Дата добавления - 07.05.2018 в 13:23
RAN Дата: Понедельник, 07.05.2018, 13:25 | Сообщение № 12
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
StoTisteg, на ту, в которой фильтра нет. :)


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеStoTisteg, на ту, в которой фильтра нет. :)

Автор - RAN
Дата добавления - 07.05.2018 в 13:25
Vetya Дата: Понедельник, 07.05.2018, 13:35 | Сообщение № 13
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
На какую строку ругается?

Ни на какую конкретно - просто алерт
 
Ответить
Сообщение
На какую строку ругается?

Ни на какую конкретно - просто алерт

Автор - Vetya
Дата добавления - 07.05.2018 в 13:35
_Boroda_ Дата: Понедельник, 07.05.2018, 13:50 | Сообщение № 14
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
У меня немного более другой вариант
[vba]
Код
Sub Макрос6()
    Dim d_ As Range, d1_ As Range
    r1_ = Range("A" & Rows.Count).End(3).Row
    r0_ = WorksheetFunction.CountIf(Range("C2").Resize(r1_ - 1), "<" & CLng(Date)) + 2
    If r1_ > r0_ Then
        Set d_ = Range("A" & r0_).Resize(r1_ - r0_ + 1, 4)
        Set d1_ = Range("A" & r0_).Resize(r1_ - r0_ + 1)
        With ActiveWorkbook.Worksheets("Итог").Sort.SortFields
            .Clear
            .Add Key:=d1_, SortOn:=xlSortOnCellColor, Order:=xlDescending, DataOption:=xlSortNormal
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(221, 217, 196)
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(218, 238, 243)
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(197, 217, 241)
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(235, 241, 222)
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(242, 220, 219)
        End With
        With ActiveWorkbook.Worksheets("Итог").Sort
            .SetRange d_
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
End Sub
[/vba]
Чуть исправил - две одинаковых строки было в выборе цвета
К сообщению приложен файл: 0141105_1.xlsm (68.7 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995


Сообщение отредактировал _Boroda_ - Понедельник, 07.05.2018, 13:59
 
Ответить
СообщениеУ меня немного более другой вариант
[vba]
Код
Sub Макрос6()
    Dim d_ As Range, d1_ As Range
    r1_ = Range("A" & Rows.Count).End(3).Row
    r0_ = WorksheetFunction.CountIf(Range("C2").Resize(r1_ - 1), "<" & CLng(Date)) + 2
    If r1_ > r0_ Then
        Set d_ = Range("A" & r0_).Resize(r1_ - r0_ + 1, 4)
        Set d1_ = Range("A" & r0_).Resize(r1_ - r0_ + 1)
        With ActiveWorkbook.Worksheets("Итог").Sort.SortFields
            .Clear
            .Add Key:=d1_, SortOn:=xlSortOnCellColor, Order:=xlDescending, DataOption:=xlSortNormal
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(221, 217, 196)
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(218, 238, 243)
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(197, 217, 241)
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(235, 241, 222)
            .Add(d1_, xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(242, 220, 219)
        End With
        With ActiveWorkbook.Worksheets("Итог").Sort
            .SetRange d_
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
End Sub
[/vba]
Чуть исправил - две одинаковых строки было в выборе цвета

Автор - _Boroda_
Дата добавления - 07.05.2018 в 13:50
Vetya Дата: Понедельник, 07.05.2018, 14:06 | Сообщение № 15
Группа: Пользователи
Ранг: Новичок
Сообщений: 15
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
У меня немного более другой вариант

Слава котикам!!! Работает спасибища огромное clap beer respect
Благодарю за помощь откликнувшимся, извиняюсь что криво оформлял тему deal
 
Ответить
Сообщение
У меня немного более другой вариант

Слава котикам!!! Работает спасибища огромное clap beer respect
Благодарю за помощь откликнувшимся, извиняюсь что криво оформлял тему deal

Автор - Vetya
Дата добавления - 07.05.2018 в 14:06
RAN Дата: Понедельник, 07.05.2018, 15:34 | Сообщение № 16
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Сань, там этих цветов... Квк на клумбе. :D
[vba]
Код
Sub Мяв()
    Dim r As Range, arColor, i&, x, Colors
    Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
                   9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)
    Application.ScreenUpdating = False
    With ActiveSheet
        .AutoFilter.Range.AutoFilter Field:=3, Operator:= _
                    xlFilterValues, Criteria2:=Array(2, Format(Date, "m\/d\/yyyy"))
        Set r = .AutoFilter.Range
        With .Sort
            .SortFields.Clear
            For Each x In Colors
                .SortFields.Add(r(1) _
              , xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = x
            Next
            .SetRange r
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .AutoFilter.Range.AutoFilter Field:=3
    End With
    Application.ScreenUpdating = True
End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеСань, там этих цветов... Квк на клумбе. :D
[vba]
Код
Sub Мяв()
    Dim r As Range, arColor, i&, x, Colors
    Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
                   9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)
    Application.ScreenUpdating = False
    With ActiveSheet
        .AutoFilter.Range.AutoFilter Field:=3, Operator:= _
                    xlFilterValues, Criteria2:=Array(2, Format(Date, "m\/d\/yyyy"))
        Set r = .AutoFilter.Range
        With .Sort
            .SortFields.Clear
            For Each x In Colors
                .SortFields.Add(r(1) _
              , xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = x
            Next
            .SetRange r
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .AutoFilter.Range.AutoFilter Field:=3
    End With
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - RAN
Дата добавления - 07.05.2018 в 15:34
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выполнение макроса только для строк с текущей датой (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!