Guru do Excel e Power BI

Enviado: **04 Mar 2017 às 19:38**

Boa noite pessoal existe alguma forma de colocar esta macro a perguntar a data que pretendo filtrar?

Sub Macro1()
'
' Macro1 Macro
'

'
    Windows("Livro 3.xlsx").Activate
    ActiveSheet.Range("$B$1:$R$6").AutoFilter Field:=13, Operator:= _
        xlFilterValues, Criteria2:=Array(2, "3/1/2017")
    Windows("Livro 2.xlsx").Activate
    Range("L17").Select
    ActiveSheet.Range("$B$1:$R$6").AutoFilter Field:=13, Operator:= _
        xlFilterValues, Criteria2:=Array(2, "3/1/2017")
    Windows("Livro 1.xlsx").Activate
    ActiveSheet.Range("$B$1:$R$12").AutoFilter Field:=13, Operator:= _
        xlFilterValues, Criteria2:=Array(2, "3/1/2017")
    Range("H20").Select
    Windows("Livro Final.xlsm").Activate
End Sub

Obrigado

Enviado: **04 Mar 2017 às 20:01**

Boa noite!!

Use uma InputBox

Código: Selecionar todos

Dim sData As String 

sData = InputBox("Digite sua data")

Att

Enviado: **04 Mar 2017 às 20:11**

e já gora como ficava o código?...obrigado..pretendo colocar a data apenas uma vez...depois ele filtra em todos os livros automaticamente...obrigado

Enviado: **05 Mar 2017 às 20:29**

Boa noite!!

Favor ler as regras do fórum!!
viewtopic.php?f=5&t=4

Regra nº 11:
Nós preferimos que os membros não façam postagens cruzadas (quando a mesma postagem é feita em diferentes fóruns). Mas quando isso ocorrer, os membros devem deixar claro os links para as postagens cruzadas.

Favor indicar as postagens cruzadas!
http://www.planilhando.com.br/forum/vie ... 10&t=23813

Att

Enviado: **06 Mar 2017 às 11:38**

alexandrevba escreveu:Boa noite!!

Favor ler as regras do fórum!!
viewtopic.php?f=5&t=4
Regra nº 11:
Nós preferimos que os membros não façam postagens cruzadas (quando a mesma postagem é feita em diferentes fóruns). Mas quando isso ocorrer, os membros devem deixar claro os links para as postagens cruzadas.

Favor indicar as postagens cruzadas!
http://www.planilhando.com.br/forum/vie ... 10&t=23813

Att

desculpe não sabia que também pertencia ao outro forum!...apenas o fiz porque estou mesmo a precisar de conseguir a macro com o máximo de brevidade...preciso que a macro filtre nas folhas e depois copie para a folha final( como me fez anteriormente ), mas com o pedido de data a filtrar e depois copiar para a folha final apenas o que foi filtrado. os ficheiros são os mesmos que disponibilizei anteriormente...mas volto a adicionar.
Muito obrigado e mais uma vez a minhas desculpas.

Enviado: **06 Mar 2017 às 12:29**

Boa tarde!!

Vejo se você abriu um tópico similar ao outro (eu vou trancar o outro tópico).

preciso que a macro filtre nas folhas e depois copie para a folha fina

Qual o critério, qual data que o código tem que saber para filtrar os dados?

Att

Enviado: **06 Mar 2017 às 15:34**

alexandrevba escreveu:Boa tarde!!

Vejo se você abriu um tópico similar ao outro (eu vou trancar o outro tópico).

preciso que a macro filtre nas folhas e depois copie para a folha fina
Qual o critério, qual data que o código tem que saber para filtrar os dados?

Att

a data é definida por mim quando clico na macro...ela pergunta qual a data e eu coloco a data depois a macro vai nos livros e filtra o que está nessa data em todos os livros e depois copia para a folha final...ou seja...a data é sempre a definir por mim...clico e a macro pergunta " qual a data a seleccionar" e eu coloco a que eu quiser e depois são filtradas todas as linhas com informação referente a essas datas e são selecionadas,copiadas e coladas na folha final..tudo seguido..em baixo depois da tabela..

Obrigado

Enviado: **06 Mar 2017 às 21:27**

Boa noite!!

Abra e descompacte o arquivo, rode a macro.

Att

Enviado: **07 Mar 2017 às 07:09**

bom dia é quase isto mesmo..agora pedia-lhe se não dá para configurar a macro de forma a que após fazer o filtro e quando estiver a seleccionar assim que encontrar uma linha em branco(marquei a azul nos livros), pare de seleccionar...para não copiar a linha de baixo onde diz: expediente/concelho/etc..e para não copiar aquele valor total..tipo a macro filtra..começa a seleccionar...assim que encontra uma linha branca, não selecciona mais(isto é para todos os livros), e então copia para a folha final....vou lhe enviar as folhas de novo..fiz lá um ajuste na macro para ver o que realmente pretendo..está quase no ponto! brigadão!!

Enviado: **07 Mar 2017 às 10:07**

Bom dia!!

Eu não consigo te entender, a sua solicitação de agora e do primeiro post, não faz tanta diferença.

assim que encontrar uma linha em branco(marquei a azul nos livros),

No anexo não vi na marcado de azul.

fiz lá um ajuste na macro para ver

O anexo não veio com código.

Vai uma outra forma de fazer a mesma coisa que pediu.

Código: Selecionar todos

Sub AleVBA_4207V2()
'Onde está escrito o nome -> AleVBA <-, altere para a guia que desejar
'Onde está escrito o nome -> Ficheiro Ramais a Executar<-, altere para a guia que desejar
    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Rws As Long, Rng As Range
    Set Wb = ThisWorkbook

    MyDir = "C:\Users\alexandre.goncalves\Downloads\Guru\"
    MyFile = Dir(MyDir & "*.xlsx")
    ChDir MyDir
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0

    Do While MyFile <> ""
        Workbooks.Open (MyFile)
        With Worksheets("Ficheiro Ramais a Executar")
            Rws = .Cells(Rows.Count, "A").End(xlUp).Row
            Set Rng = Range(.Cells(2, 1), .Cells(Rws, 18))
            Rng.Copy Wb.Worksheets("AleVBA").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            ActiveWorkbook.Close True
        End With
        MyFile = Dir()
    Loop
    'A linha abaixo foi comentada, apenas deleta a coluna A
    'Worksheets("AleVBA").Range("A:A").Delete
End Sub

Att

Enviado: **07 Mar 2017 às 11:42**

Viva é quase isto, mas não está a perguntar a data a filtrar...obrigado

Enviado: **07 Mar 2017 às 14:21**

viva já consegui resolver..diga-me e se o ficheiro final estiver numa pasta diferente dos outros ficheiros?...como posso fazer?...obrigado

Enviado: **08 Mar 2017 às 06:07**

nmareis escreveu:viva já consegui resolver..diga-me e se o ficheiro final estiver numa pasta diferente dos outros ficheiros?...como posso fazer?...obrigado

bom dia,

estive a verificar e este código é mais rápido que o último que me enviou...pedia-lhe por favor para colocar este a não copiar a parte de baixo como fez anteriormente no outro...só até á linha em branco, sem o total e a parte que diz expediente..etc..

Código: Selecionar todos

Sub Reis()
    Dim sFolder As String
    Dim sFile As String
    Dim wbD As Workbook, wbS As Workbook
     
    Application.ScreenUpdating = False
    Set wbS = ThisWorkbook
    sFolder = wbS.Path & "\"
     
    sFile = Dir(sFolder)
    Do While sFile <> ""
         
        If sFile <> wbS.Name Then
            Set wbD = Workbooks.Open(sFolder & sFile)
            wbD.Sheets("Ficheiro Ramais a Executar").Range("A2:R10000").Copy
            wbS.Activate
            Sheets("Folha2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            wbD.Close savechanges:=True
        End If
        sFile = Dir
    Loop
    Call AleVBA_Deletar
    Application.ScreenUpdating = True
End Sub
Sub AleVBA_Deletar()
Dim sEntrada As String
Dim lData As Long

sEntrada = Application.InputBox("Digite a data no formato ""DD/mm/aaaa""")
lData = CLng(DateValue(sEntrada))

Worksheets("Folha2").Range("A1").AutoFilter Field:=14, Criteria1:=">=" & lData, Operator:=xlAnd, Criteria2:="<" & lData + 1
    Dim lRows As Long
    'Application.Calculation = xlCalculationManual
        For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
            If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
        Next lRows
        ActiveSheet.AutoFilterMode = False
    'Application.Calculation = xlCalculationAutomatic

End Sub

obrigado

Enviado: **08 Mar 2017 às 08:25**

Bomdia!!

Altere essa linha.

Código: Selecionar todos

Set Rng = Range(.Cells(2, 1), .Cells(Rws, 18))

Para...

Código: Selecionar todos

Set Rng = Range(.Cells(2, 2), .Cells(Rws, 18))

Att

Enviado: **08 Mar 2017 às 09:13**

alexandrevba escreveu:Bomdia!!

Altere essa linha.
Código: Selecionar todos
Set Rng = Range(.Cells(2, 1), .Cells(Rws, 18))
Para...
Código: Selecionar todos
Set Rng = Range(.Cells(2, 2), .Cells(Rws, 18))
Att

viva...neste código não tem essa linha?????

Código: Selecionar todos

Sub Reis()
    Dim sFolder As String
    Dim sFile As String
    Dim wbD As Workbook, wbS As Workbook
     
    Application.ScreenUpdating = False
    Set wbS = ThisWorkbook
    sFolder = wbS.Path & "\"
     
    sFile = Dir(sFolder)
    Do While sFile <> ""
         
        If sFile <> wbS.Name Then
            Set wbD = Workbooks.Open(sFolder & sFile)
            wbD.Sheets("Ficheiro Ramais a Executar").Range("A2:R5000").Copy
            wbS.Activate
            Sheets("Preenchimento").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            wbD.Close savechanges:=True
        End If
        sFile = Dir
    Loop
    Call AleVBA_Deletar
    Application.ScreenUpdating = True
End Sub
Sub AleVBA_Deletar()
Dim sEntrada As String
Dim lData As Long

sEntrada = Application.InputBox("Digite a data no formato ""DD/mm/aaaa""")
lData = CLng(DateValue(sEntrada))

Worksheets("Preenchimento").Range("A1").AutoFilter Field:=14, Criteria1:=">=" & lData, Operator:=xlAnd, Criteria2:="<" & lData + 1
    Dim lRows As Long
    'Application.Calculation = xlCalculationManual
        For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
            If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
        Next lRows
        ActiveSheet.AutoFilterMode = False
    'Application.Calculation = xlCalculationAutomatic

End Sub

é este que pretendo que pare na linha bazia em baixo e não copie o total e os textos expediente, etc..como fez no anterior código..este:

Código: Selecionar todos

Sub AleVBA_4207V2()
'Onde está escrito o nome -> AleVBA <-, altere para a guia que desejar
'Onde está escrito o nome -> Ficheiro Ramais a Executar<-, altere para a guia que desejar
    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Rws As Long, Rng As Range
    Set Wb = ThisWorkbook

    MyDir = "C:\cme\Fic. Partilhados\Ramais\"
    MyFile = Dir(MyDir & "*.xlsx")
    ChDir MyDir
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0

    Do While MyFile <> ""
        Workbooks.Open (MyFile)
        With Worksheets("Ficheiro Ramais a Executar")
            Rws = .Cells(Rows.Count, "A").End(xlUp).Row
            Set Rng = Range(.Cells(2, 1), .Cells(Rws, 18))
            Rng.Copy Wb.Worksheets("Preenchimento").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            ActiveWorkbook.Close True
        End With
        MyFile = Dir()
    Loop
    Call AleVBA_Deletar
    Application.ScreenUpdating = True
End Sub


Sub AleVBA_Deletar()
Dim sEntrada As String
Dim lData As Long

sEntrada = Application.InputBox("Digite a data no formato ""DD/mm/aaaa""")
lData = CLng(DateValue(sEntrada))

Worksheets("Preenchimento").Range("A1").AutoFilter Field:=14, Criteria1:=">=" & lData, Operator:=xlAnd, Criteria2:="<" & lData + 1
    Dim lRows As Long
    'Application.Calculation = xlCalculationManual
        For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
            If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
        Next lRows
        ActiveSheet.AutoFilterMode = False
    'Application.Calculation = xlCalculationAutomatic

End Sub

..se houver possibilidade de agilizar melhor agradeço..assim poderá ficar mais rápido

Guru do Excel e Power BI

Completar macro

Completar macro

Re: ajuda a completar macro

ajuda a completar macro

Re: Completar macro

Re: Completar macro

Re: Completar macro

Re: Completar macro

Re: Completar macro

Completar macro

Re: Completar macro

Completar macro

Completar macro

Re: Completar macro

Re: Completar macro

Re: Completar macro