Este fórum está sendo desativado

[Mablove]

Boa noite gente, preciso muito de ajuda. estou criando uma planilha com algumas atribuições em macro. Milha planilha tem cerca de 4 abas e em 3 delas possuo diversas colunas com diferentes datas. preciso construir uma consulta de datas em todas as abas e nas diversas colunas, que me resulte todos os resultados, se possível uma consulta entre duas datas (inicio e fim) ou um critério em que os resultados possuam mês e ano idênticos o da pesquisa. Já tentei de diversas formas mas não sei como fazer. ME AJUDEM POOOR FAVOOOR


Preciso que a planilha final fique assim:

Produto - Nome da planilha - Lote - Data(que esteja dentro do critério) -
xx xxxx xx xx/xx/yyyy

[alexandrevba]

Bom dia!!

Segue um esboço para teste!
Agora é só implementar conforme sua necessidade.

Código: Selecionar todos

Public Sub AleVBA_6187()
'https://gurudoexcel.com/forum/viewtopic.php?f=12&t=6187
'Copia baseado em data de várias guias para uma guia resumo
Dim Ws As Worksheet, LR1 As Long, LR2 As Long
Dim lr As Long
Dim dDate1 As Long
Dim dDate2 As Long
Dim wsConsultas As Worksheet
Set wsConsultas = Worksheets("Consultas")
'Encontra a ultima linha de cada guia
lr = wsConsultas.UsedRange.Rows(UBound(wsConsultas.UsedRange.Value)).Row
'Verifica quais as datas como critério
dDate1 = DateValue(Format(wsConsultas.Range("O1"), "dd/mm/yyyy")) 'Digite a data Incial nesta célula
dDate2 = DateValue(Format(wsConsultas.Range("P1"), "dd/mm/yyyy")) 'Digite a data Final nesta célula
'Desliga a tela de atualização
Application.ScreenUpdating = False
'Limpa as células da guia para onde os dados são copiados
    With wsConsultas.Range(Cells(2, 1), Cells(lr, 12))
        .ClearContents
    End With
'Copia os dados das guias para a guia Consulta
    For Each Ws In ThisWorkbook.Worksheets
         If Ws.Name <> "Menu" And Ws.Name <> "Consultas" Then
            LR1 = ThisWorkbook.Worksheets("Consultas").Range("A" & Rows.Count).End(xlUp).Row + 1
            LR2 = Ws.Range("A" & Rows.Count).End(xlUp).Row
            ThisWorkbook.Worksheets("Consultas").Range("L" & LR1).Resize(LR2 - 1).Value = Ws.Name
            Ws.Range("A2:L" & LR2).Copy ThisWorkbook.Worksheets("Consultas").Range("A" & LR1)
         End If
     Next Ws
'Filtra os dados
    With wsConsultas
        .AutoFilterMode = False
        With .Range("A1:L1")
            .AutoFilter
            .AutoFilter Field:=4, Criteria1:=">=" & dDate1, Operator:=xlAnd, Criteria2:="<=" & dDate2
        End With
    End With
Application.ScreenUpdating = True
End Sub

Att

[Mablove]

OOi Alexandrevba, não consegui rodar o código com sucesso. está dando erro nessa linha:
ThisWorkbook.Worksheets("Consultas").Range("L" & LR1).Resize(LR2 - 1).Value = Ws.Name

[alexandrevba]

Bom dia!!

Se você verificou meu post anterior, eu disse favor adaptar!!

Preencha suas guias com dados, pois o código verifica o total de linhas de cada um das guias que precisa ser copiadas. Eu volto a dizer, favor adaptar!!!!!!!!!

Att