Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Проверка количества дней в месяце
 
#1
12.11.2014 02:35:41
Подскажите плз. где подглядеть макрос по поиску из закраске дубликатов.
Вроде постоянно обсуждается, но в основном с использованием УФ и формул,
а надо что-то простое и именно макросом.
Изменено: sofi - 12.11.2014 13:57:30
 
 
 
#2
12.11.2014 05:13:46
http://www.planetaexcel.ru/techniques/14/198/
 
 
 
#3
12.11.2014 05:39:23
Спасибо! Буду разбираться.
Вообще-то, мне нужно по одному столбцу.
Может есть что-нибудь по "топорнее"!
 
 
 
#4
12.11.2014 05:46:12
Выделяйте один столбец )) В каком смысле топорнее - больше кода, медленнее работа?
 
 
 
#5
12.11.2014 06:29:58
Да нет! Массивом оно конечно лучше.
Правда придется создавать "базу дубликатов" большую.
Мне нужно искать дубликаты месяцев за 20 лет, т.е. 240 ячеек.
И деть ее куда-то надо, ведь этот макрос работает если "база" и
диапазон проверки на одном листе.
А на лист, что-либо лишнее крайне не хочется заносить, во как!
Да и "цветомузыка" эта мне не нужна, но это мелочи, отключил.
 
 
 
#6
12.11.2014 06:31:35
Цитата
sofi пишет: Да и "цветомузыка" эта мне не нужна
Но просите
Цитата
sofi пишет: по поиску из закраске дубликатов.
 
 
 
#7
12.11.2014 06:55:06
Нее! Мне один цвет нужен, я его и сделал. :)
Вообще задача несколько в другом, закраска, это так, "рюшечки"!
Нужно проверять, на соответствии календарному, ко-во дней в месяцах из которых состоит столбец таблицы.
При условии, что любой месяц может быть "разбит" на периоды с произвольным ко-вом дней.
Т.е. считать общее ко-во дней в периодах и проверять соответствует ли оно календарному.
Вот я и думаю, как это реализовать с минимумом жертв.
См. Пример
 
 
 
#8
12.11.2014 13:58:59
Уважаемые модераторы измените плз. название темы на:
"Проверка количества дней в месяце"
 
 
 
#9
12.11.2014 16:09:08
не очень понял насчет msgbox :)
Код
Sub bad_periods()
Dim i&, rBase As Range, a, dct As Object
'Set rBase = Application.InputBox("Диапазон из 2 столбцов:", Default:=[a1].CurrentRegion.Address, Type:=8)
Set rBase = Range("A1:B19")
a = rBase.Value
Set dct = CreateObject("scripting.dictionary")
For i = 1 To UBound(a, 1)
    dct.Item(a(i, 1)) = dct.Item(a(i, 1)) + a(i, 2)
Next
For i = 1 To UBound(a, 1)
    If Application.WorksheetFunction.EoMonth(a(i, 1), 0) + 1 - a(i, 1) < dct(a(i, 1)) Then
        MsgBox "MsgBox в строке " & i
        rBase(i, 1).Resize(1, 2).Interior.Color = RGB(255, 0, 0)
    Else
        rBase(i, 1).Resize(1, 2).Interior.Color = RGB(0, 255, 0)   
    End If
Next
End Sub

формула для условного форматирования:
=СУММЕСЛИ($A$1:$A$19;$A1;$B$1:$B$19)>КОНМЕСЯЦА($A1;0)+1-$A1 для подсветки всех неправильно забитых периодов
ее же можно для условия проверки данных - для предотвращения ввода (только не ">", а "<=" ;)
F1 творит чудеса
 
 
 
#10
12.11.2014 16:46:12
Вставил Ваш макрос в Пример, ругается на:
Код
Application.WorksheetFunction.EoMonth(a(i, 1), 0) + 1 - a(i, 1) < dct(a(i, 1))
А вывод MsgBox, это значит показать сообщение, что все правильно либо нет. :)  
 
 
 
#11
12.11.2014 17:06:02
Цитата
Если данная функция недоступна или возвращает ошибку #ИМЯ?, установите и загрузите надстройку «Пакет анализа».
http://office.microsoft.com/ru-ru/excel-help/HP005209076.aspx
F1 творит чудеса
 
 
 
#12
12.11.2014 17:13:01
ну или замените эту строку, чтобы не мучиться:

Код
If DateSerial(Year(a(i, 1)), Month(a(i, 1)) + 1, 1) - a(i, 1) < dct(a(i, 1)) Then
F1 творит чудеса
 
 
 
#13
12.11.2014 17:14:27
Цитата
установите и загрузите надстройку «Пакет анализа»
Цитата
"Обижаешь начальник!"
Это должно быть на вооружении каждого "бойца" на фронте Excel!  :)  
Кстати проверил УФ, работает, если сумма дней больше календарных, если меньше фиг!  :(
Изменено: sofi - 12.11.2014 17:17:14
 
 
 
#14
12.11.2014 17:18:36
ну вот так работает, и предыдущий у меня работал в 2010.
Код
Sub bad_periods()
Dim i&, rBase As Range, a, dct As Object
'Set rBase = Application.InputBox("Диапазон из 2 столбцов:", Default:=[a1].CurrentRegion.Address, Type:=8)
Set rBase = Range("A1:B19")
a = rBase.Value
Set dct = CreateObject("scripting.dictionary")
For i = 1 To UBound(a, 1)
    dct.Item(a(i, 1)) = dct.Item(a(i, 1)) + a(i, 2)
Next
Dim s$, t As Boolean, mdays As Double
s = "Ошибки в строках: "
For i = 1 To UBound(a, 1)
'    On Error Resume Next
'    mdays = Application.WorksheetFunction.EoMonth(a(i, 1), 0) + 1 - a(i, 1)
'    If Err <> 0 Then
        mdays = DateSerial(Year(a(i, 1)), Month(a(i, 1)) + 1, 1) - a(i, 1)
'    End If
    If mdays < dct(a(i, 1)) Then
        s = s & i & ", "
        t = True
        rBase(i, 1).Resize(1, 2).Interior.Color = RGB(255, 0, 0)
    Else
        rBase(i, 1).Resize(1, 2).Interior.Color = xlNone
    End If
Next
If t Then MsgBox (Left(s, Len(s) - 2)) Else MsgBox "Всё в порядке"
End Sub
Цитата
sofi пишет: если меньше фиг!
а что должно быть если меньше? заливки быть не должно, условное форматирование снимается. Ну или если нужна другая закраска, то тогда поставьте еще одну (с другим знаком) формулу на другой цвет
F1 творит чудеса
 
 
 
#15
12.11.2014 17:21:52
Заменил строку в макросе, пока все хорошо, респект! :)
Код
EoMonth
проверил, есть в наличии, т.ч. дело похоже в коде.
 
 
 
#16
12.11.2014 17:34:18
жмите кнопку
F1 творит чудеса
 
 
 
#17
12.11.2014 18:24:11
Цитата
а что должно быть если меньше
Больше, меньше должно выделяться, равно заливки нет.
Т.е. вот так:
Код
    If mdays < dct(a(i, 1)) Or mdays > dct(a(i, 1)) Then
Осталось сделать, чтобы пустые строки между месяцами игнорировались.
Изменено: sofi - 12.11.2014 19:03:09
 
 
 
#18
12.11.2014 19:16:57
Код
Sub bad_periods()
Dim i&, rBase As Range, a, dct As Object
Set rBase = Range("A1:B19")
a = rBase.Value
Set dct = CreateObject("scripting.dictionary")
For i = 1 To UBound(a, 1)
    dct.Item(a(i, 1)) = dct.Item(a(i, 1)) + a(i, 2)Next
Dim s$, t As Boolean, mdays As Double
s = "Ошибки в строках: "
   For i = 1 To UBound(a, 1)
   mdays = DateSerial(Year(a(i, 1)), Month(a(i, 1)) + 1, 1) - a(i, 1)
    If mdays < dct(a(i, 1)) Or mdays > dct(a(i, 1)) Then
      s = s & i & ", "
      t = True
      rBase(i, 1).Resize(1, 2).Interior.ColorIndex = 40
       Else
      rBase(i, 1).Resize(1, 2).Interior.ColorIndex = -4142
    End If
   
    If a(i, 1) = 0 Then
       rBase(i, 1).Resize(1, 2).Interior.ColorIndex = -4142
    End If
   Next
Код
If t Then MsgBox (Left(s, Len(s) - 2)) Else MsgBox "Все правильно!"
Код
End Sub

В итого, как-то так получается.
Еще бы придумать, чтобы вместо номеров строк, содержащих ошибки, выводился список месяцев?!
А так, почти ляпота!
Изменено: sofi - 12.11.2014 20:59:55
 
 
 
#19
12.11.2014 19:47:02
Цитата
sofi пишет:Еще бы придумать, чтобы вместо номеров строк, содержащих ошибки, выводился список месяцев?!
Так?
Изменено: Ivan.kh - 12.11.2014 20:18:41
 
 
 
#20
12.11.2014 20:56:51
Выдает ошибку в первом месяце.
Список в идеале столбиком бы, но боюсь муторно это.
Изменено: sofi - 12.11.2014 21:52:52
 
 
 
#21
12.11.2014 21:31:38
Вывод столбиком нарисовал:    
Код
     If a(i, 1) = a(i - 1, 1) Or a(i, 1) = "" Then
         s = s
         t = True
      Else
         s = s & vbCrLf & с & "  "
         t = True
     End If
Изменено: sofi - 12.11.2014 21:52:14
 
 
 
#22
12.11.2014 21:57:49
Вторая строка лишняя
F1 творит чудеса
 
 
 
#23
13.11.2014 04:40:48
По идее надо подавить появление MsgBox, когда цикл проходит по
пустым строкам, т.е. 3 строка тоже не нужна, но должна сохраниться логика:
Код
If a(i, 1) = a(i - 1, 1) Or a(i, 1) = "" Then

Кстати ошибка здесь сидела
Код
 a(i - 1, 1)

Выходим за пределы цикла/диапазона, но поскольку сверху шапка таблицы, то не смертельно
Код
On Error Resume Next

Для наглядности встроил этот макрос в пример посерьезней, он ближе к конечной цели.
Изменено: sofi - 13.11.2014 23:35:52
 
 
 
#24
13.11.2014 08:49:35
Цитата
sofi пишет:
Выдает ошибку в первом месяце.
Только что проверил файл, вроде бы нормально сработал
Изменено: Ivan.kh - 13.11.2014 08:51:15
 
 
 
#25
13.11.2014 09:32:44
Поменяйте дни в Марте 2011 и нажмите кнопку!
 
 
 
#26
13.11.2014 10:29:46
Точно, первый месяц не учел, теперь должно все норм быть.
 
 
 
#27
13.11.2014 14:27:49
Проверил, вроде все правильно! Респект!  :)
Изменено: sofi - 14.11.2014 05:30:13
 
 
 
#28
13.11.2014 23:30:29
Подправил логику, чтобы MsgBox не вылазил на пустых строках и в сообщениях отражались
для наглядности дни календарные и фактически введенные.  
 
 
 
Страницы: 1
Наверх