Поиск по месяцам

[staniiislav]

Здравствуйте Уважаемые знатоки.
Скинул файлик, нужна помощь доделать макрос, не считает гад по месяцам.
фиолетовая кнопка а процедура в модуле month1, посмотрите как происходит поиск и выдача данных на 3-х других кнопках, и нужно чтобы четвертая кнопка выводила из таблицы БД в таблицу Книга1Стас данные по месяцу определенному в А1 в книге Книга1Стас.
Отдельное спасибо nilem, он помогал сделать в этом примере первые два макроса (кнопки).
С Ув. Staniiislav

[IgorGO]

замените
If x(i, 1) = (imonth) Then
на
If cstr(month(x(i, 1))) = (imonth) Then

нельзя номер месяца (да еще в текстовом формате) сравнивать с датой, не будут они равны не при каких обстоятельствах. "1" <> 07.01.2010, хоть месяц у них и одинаковый.

[staniiislav]

Спасибо IgorGO. А какие есть предложения для того чтобы вытаскивать данные по месяцу? может как-то в буквенном выражении указывать что искать?

[IgorGO]

imonth as integer - обьявить как целочисленное переменную
imonth = month([A1]) - присвоить номер
If month(x(i, 1)) = imonth - сравнивать номера месяцев.
но это все мелочи.
только заметил - зачем скобки вокруг imonth? их убираем, но это тоже мелочи.

[staniiislav]

Все равно не работает!

Вот нашел какой-то кусок кода поиска по месяцу, может поможете объединить с моим кодом... если это актуально:

"Здраствуйте, уважаемые.
К примеру в ячейке А1 значение "10"
Мне нужно в определенном диапазоне, например в столбце B, в котором содержатся даты, найти даты 10-го месяца с помощью функции Find
Вроде бы теоретически все просто, но Find не понимает символ точки в дате, если это делать вот так: это было изначальное условие в примере, а вот конечное решение этого условия:

Код: Выделить всё
With Columns(2)
Set c =.Find( Cells(1,1) & "/*/????", LookIn:=xlformulas, lookat:=xlwhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do

''''''' бла бла бла

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

Может подскажите как применить данный код к моему макросу? Ели конечно я правильно понял, что этот код ищет по месяцу
Но напомню, меня интересуют определенный месяц, чтобы данные выводились за определенный месяц
Заранее спасибо

[doober]

Все равно не работает!

Не может быть,согласно рекомендаций Игоря.

Sub month1()     
Dim wsh As Worksheet, wb As Workbook, x, i As Long, k As Long, imonth As Integer
Application.ScreenUpdating = False
imonth = month([a1])
Set wb = GetObject(ThisWorkbook.Path & "\БД.xls")
For Each wsh In wb.Worksheets
    x = Range("A1:E" & Cells(Rows.Count, 3).End(xlUp).Row).Value
    For i = 1 To UBound(x, 1) Step 16    ñòðîêå
        If month(CDate(x(i, 1))) = imonth Then
            wsh.Range("A1:E16").Offset(i - 1).Copy Range("A2").Offset(16 * k)
            k = k + 1
        End If
    Next i
Next wsh
wb.Close (False)

Application.ScreenUpdating = True
End Sub

Проверил,работает

[staniiislav]

Сообщение от doober

Не может быть,согласно рекомендаций Игоря.

Sub month1()     
Dim wsh As Worksheet, wb As Workbook, x, i As Long, k As Long, imonth As Integer
Application.ScreenUpdating = False
imonth = month([a1])
Set wb = GetObject(ThisWorkbook.Path & "\БД.xls")
For Each wsh In wb.Worksheets
    x = Range("A1:E" & Cells(Rows.Count, 3).End(xlUp).Row).Value
    For i = 1 To UBound(x, 1) Step 16    ñòðîêå
        If month(CDate(x(i, 1))) = imonth Then
            wsh.Range("A1:E16").Offset(i - 1).Copy Range("A2").Offset(16 * k)
            k = k + 1
        End If
    Next i
Next wsh
wb.Close (False)

Application.ScreenUpdating = True
End Sub

Проверил,работает

Может я чего-то не понимаю, я тоже проверил, и выдает постоянно одни и те же значения, даже если меняешь месяц в ячейке А1. И в БД три записи с 1 месяцем(январь), а выдает только первые две!

[doober]

Добавте красное

Sub month1()
Dim wsh As Worksheet, wb As Workbook, x, i As Long, k As Long, imonth As Integer
Application.ScreenUpdating = False
imonth = Month([a1])
Set wb = GetObject(ThisWorkbook.Path & "\БД.xls")
For Each wsh In wb.Worksheets
    x = wsh.Range("A1:E" & Cells(Rows.Count, 3).End(xlUp).Row).Value
    For i = 1 To UBound(x, 1) Step 16
        If Month(CDate(x(i, 1))) = imonth Then
        
        
            wsh.Range("A1:E16").Offset(i - 1).Copy Range("A2").Offset(16 * k)
            k = k + 1
        End If
    Next i
Next wsh
wb.Close (False)

Application.ScreenUpdating = True
End Sub

[staniiislav]

Сообщение от doober

Добавте красное

Sub month1()
Dim wsh As Worksheet, wb As Workbook, x, i As Long, k As Long, imonth As Integer
Application.ScreenUpdating = False
imonth = Month([a1])
Set wb = GetObject(ThisWorkbook.Path & "\БД.xls")
For Each wsh In wb.Worksheets
    x = wsh.Range("A1:E" & Cells(Rows.Count, 3).End(xlUp).Row).Value
    For i = 1 To UBound(x, 1) Step 16
        If Month(CDate(x(i, 1))) = imonth Then
        
        
            wsh.Range("A1:E16").Offset(i - 1).Copy Range("A2").Offset(16 * k)
            k = k + 1
        End If
    Next i
Next wsh
wb.Close (False)

Application.ScreenUpdating = True
End Sub

работает очень не корректно!
Я уже даже не знаю что бы придумать...

м нужно чтобы искало только на листе в БД, который соответствует году введенному в А1(Книга1Стас)

[EugeneS]

Сообщение от staniiislav

работает очень не корректно!
Я уже даже не знаю что бы придумать...
м нужно чтобы искало только на листе в БД, который соответствует году введенному в А1(Книга1Стас)

попробуйте вот так:

Sub month1()
Dim wsh As Worksheet, wb As Workbook, x, i As Long, k As Long, imonth As String, shname As String, ipar As String
Application.ScreenUpdating = False
imonth = Month([a1]): shname = Year([a1]): ipar = [b1]
Set wb = GetObject(ThisWorkbook.Path & "\БД.xls")
On Error GoTo Handler: With wb.Sheets(shname):
    x = .Range("A1:E" & .Cells(Rows.Count, 3).End(xlUp).Row).Value
    For i = 1 To UBound(x, 1) Step 16
        If Month(x(i, 1)) = (imonth) And x(i, 2) = ipar Then
            .Range("A1:E16").Offset(i - 1).Copy Range("A2").Offset(16 * k)
            k = k + 1
        End If
    Next i
wb.Close (False): End With: On Error GoTo 0: Application.ScreenUpdating = True: Exit Sub
Handler:
MsgBox "Лист с именем " & shname & " отсутствует в книге БД.xls", vbInformation: wb.Close (False): Exit Sub
End Sub