Excel Pesquisar por mês no Excel 2007 VBA

Bikke · 8 de abril de 2023

Boa noite

Venho aqui solicitar ajuda para uma pesquisa em várias Abas numa planilha.

A planilha que vai em anexo, tem várias Abas.

Desde a Aba Ano2019 a Ano2030

O que eu pretendo é:
Na Aba Mensal, na célula A2 e na célula A3 serão colocadas datas, em A2 eu coloco (exemplo, 01-03-2023 ) que é o primeiro dia do mês pretendido, e em A3 eu coloco o fim do mês pretendido, ( exemplo, 31-03-2023 ) e o código VBA deverá ir buscar a informação às Abas, Ano2019, Ano2020, Ano2021, Ano2022, Ano2023, Ano2024, Ano2025 até à Aba Ano2030.

Os dados deverão ir para a Aba Mensal desde a célula B7 a J41, e deverá ter o nome da Aba, o Nº da pessoa, o Nome da pessoa, os serviços, os Turnos, a Data a gozar e o Periodo do dia a gozar, referente ao mês que escolhi de todas as pessoas que gozaram nesse mesmo mês e por ordem de data ( por ordem crescente ).

Já coloquei um mês como exemplo para verem o que pretendo.

Quando digo que é para colocar o inicio do mês em A2 e em A3 o fim do mês, também pode ser na célula A2 se colocar Março 2023 e o código VBA fazer a mesma função, ou outra função que faça o que pretendo, o que interessa é o resultado final ser o mesmo que se encontra na Aba Mensal.

Pretendo também que, assim que se colocar a primeira data na Aba Mensal na célula A2, deverá limpar toda a área de B7 a J41.

Espero que me tenha explicado bem.

Obrigado desde já.

Cumprimentos

1792435093_Compensaes_2023_V8.xls

Wendell Menezes · 8 de abril de 2023

@Bikke Boa noite,

Para consolidar as férias cole o código abaixo em qualquer módulo e execute a macro SEARCH:

Sub SEARCH()

    Dim wsM As Worksheet
    Dim ws  As Worksheet
    Dim LR  As Long
    Dim LRM As Long
    Dim r   As Long
    
    Set wsM = Sheets("Mensal")
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            If Left(LCase(.Name), 3) = "ano" Then
                LR = LastRow(ws, 8)
                For r = 4 To LR
                    If .Cells(r, 8) >= wsM.Range("A2") And .Cells(r, 8) <= wsM.Range("A3") Then
                        LRM = LastRow(wsM, 3) + 1
                        .Range("B" & r & ":I" & r).Copy
                        wsM.Range("B" & LRM) = .Name
                        wsM.Range("C" & LRM).PasteSpecial xlPasteValues
                    End If
                Next
            End If
        End With
    Next
    
    wsM.Range("B6:J" & LastRow(wsM, 3)).Sort wsM.Range("I6"), Header:=xlYes

End Sub

Function LastRow(ByVal ws As Worksheet, ByVal Col As Integer) As Long
    LastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function

Para apagar os dados quando inserir a data inicial, cole o código abaixo no módulo da aba "Mensal":

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(False, False) = "A2" Then
        Range("A7:J1000").ClearContents
    End If
End Sub

Bikke · 8 de abril de 2023

Boa noite

Obrigado desde já pela tua ajuda.

Coloquei o código VBA do SEARCH no modulo da Aba Mensal e depois coloquei a data em A2 ( 01-03-2023 ) e em A3 ( 31-03-2023 )

E não acontece nada.

Está alguma coisa errada aqui??

Wendell Menezes · 8 de abril de 2023

Ficou assim?

Esse código irá apagar todas as linhas da aba mensal quando o valor da célula A2 for alterado

Bikke · 8 de abril de 2023

Não me refiro a esse código

Mas sim a este

Sub SEARCH()

    Dim wsM As Worksheet
    Dim ws  As Worksheet
    Dim LR  As Long
    Dim LRM As Long
    Dim r   As Long
    
    Set wsM = Sheets("Mensal")
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            If Left(LCase(.Name), 3) = "ano" Then
                LR = LastRow(ws, 8)
                For r = 4 To LR
                    If .Cells(r, 8) >= wsM.Range("A2") And .Cells(r, 8) <= wsM.Range("A3") Then
                        LRM = LastRow(wsM, 3) + 1
                        .Range("B" & r & ":I" & r).Copy
                        wsM.Range("B" & LRM) = .Name
                        wsM.Range("C" & LRM).PasteSpecial xlPasteValues
                    End If
                Next
            End If
        End With
    Next
    
    wsM.Range("B6:J" & LastRow(wsM, 3)).Sort wsM.Range("I6"), Header:=xlYes

End Sub

Function LastRow(ByVal ws As Worksheet, ByVal Col As Integer) As Long
    LastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function

Eu o coloquei no módulo da Aba Mensal, e depois coloquei as datas, e ao as colocar, devia aparecer o resultado final, e não acontece nada.

Wendell Menezes · 8 de abril de 2023

Esse daí é uma SUB, para ser atividado através de um botâo por exemplo, ou pressionando F5 direto no editor VBA.

Se quer que ele seja ativado quando a data final for inserida, pode usar essa outra versão aqui no módulo da aba da Mensal, já serve tanto para limpeza (quando altera A2) quanto puxar os dados (quando altera A3)

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim wsM As Worksheet
    Dim ws  As Worksheet
    Dim LR  As Long
    Dim LRM As Long
    Dim r   As Long

    If Target.Address(False, False) = "A2" Then
        Range("A7:J1000").ClearContents
            ElseIf Target.Address(False, False) = "A3" Then
        Set wsM = Sheets("Mensal")
            For Each ws In ThisWorkbook.Worksheets
                With ws
                    If Left(LCase(.Name), 3) = "ano" Then
                        LR = LastRow(ws, 8)
                        For r = 4 To LR
                            If .Cells(r, 8) >= wsM.Range("A2") And .Cells(r, 8) <= wsM.Range("A3") Then
                                LRM = LastRow(wsM, 3) + 1
                                .Range("B" & r & ":I" & r).Copy
                                wsM.Range("B" & LRM) = .Name
                                wsM.Range("C" & LRM).PasteSpecial xlPasteValues
                            End If
                        Next
                    End If
                End With
            Next
        wsM.Range("B6:J" & LastRow(wsM, 3)).Sort wsM.Range("I6"), Header:=xlYes
    End If
    
End Sub

Function LastRow(ByVal ws As Worksheet, ByVal Col As Integer) As Long
    LastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function