Tópicos relacionados a códigos VBA, gravação de macros, etc.
Por rit 25 Jan 2018 às 09:09
Membro 3 Estrelas
Mensagens: 271
Reputação: 7
#29686
Bom dia Amigos,

Estou anexando uma planilha e gostaria de saber se alguém consegue escrever um código que faça o seguinte:

Fazer uma verificação na coluna "data de entrega" e pegar tudo que seja das datas que ja passou até duas semanas para frente e faça outra verificação na coluna "nome abreviado" e me retorne uma opção para que eu escolha o fornecedor que esta na coluna "nome abreviado" para eu selecionar qual eu quero que ele liste essas linhas de duas semanas para frente em outro documento com o nome que eu selecionar> Exemplo aperto o botão ele faz a coleta dos dados com as datas que ja passou até duas semanas para frente e em seguida eu possa selecionar o fornecedor que eu quero que ele faça a lista, e gere outra pasta com o nome que eu escolher.

Obrigado!
Apenas usuários registrados podem ver ou baixar anexos.
Avatar do usuário
Por alexandrevba 26 Jan 2018 às 09:57
Excel Expert
Mensagens: 1643
Reputação: 578
#29732
Bom dia!!

Talvez isso ajude a ter uma ideia...
Código: Selecionar todosSub AleVBA_6158()
Dim lr As Long
Dim sNomeAbreviado As String

lr = Cells(Rows.Count, "A").End(xlUp).Row

With Worksheets("Planilha1")
    [K1].Value = "InsForm"
    .AutoFilterMode = False
    .Range("K2").Formula = "=INT((TODAY()-I2)/7)"
    .Range("K2").AutoFill Destination:=Range("K2:K" & lr)
    .Range("A1:K1").AutoFilter
    .Range("A1:K1").AutoFilter Field:=11, Criteria1:=">" & 2
    sNomeAbreviado = InputBox("Selecione o Nome Abreviado")
    .Range("A1:K1").AutoFilter Field:=5, Criteria1:=sNomeAbreviado
    .Range("A2:J" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Worksheets("AleVBA").Range("A1")
'Favor criar uma guia com o nome AleVBA
End With

End Sub

Att
Avatar do usuário
Por alexandrevba 26 Jan 2018 às 12:38
Excel Expert
Mensagens: 1643
Reputação: 578
#29742
Bom dia!!
Caso você deseja digitar o nome do arquivo em uma InputBox, siga a ideia que eu utilizei no código para filtrar (
Código: Selecionar todos sNomeAbreviado = InputBox("Selecione o Nome Abreviado")
)
Código: Selecionar todosSub AleVBA_6158()
'https://gurudoexcel.com/forum/viewtopic.php?f=12&t=6158

Dim lr As Long
Dim sNomeAbreviado As String
Dim wb As Workbook

lr = Cells(Rows.Count, "A").End(xlUp).Row

With Worksheets("Planilha1")
    [K1].Value = "InsForm"
    .AutoFilterMode = False
    .Range("K2").Formula = "=INT((TODAY()-I2)/7)"
    .Range("K2").AutoFill Destination:=Range("K2:K" & lr)
    .Range("A1:K1").AutoFilter
    .Range("A1:K1").AutoFilter Field:=11, Criteria1:=">" & 2
    sNomeAbreviado = InputBox("Selecione o Nome Abreviado")
    .Range("A1:K1").AutoFilter Field:=5, Criteria1:=sNomeAbreviado
    .Range("A2:J" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Worksheets("AleVBA").Range("A1")
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("AleVBA").Copy Before:=wb.Sheets(1)
    wb.SaveAs "C:\temp\FileAleVBA.xlsx" '<- favor indicar o caminho onde pretende salvar o arquivo
End With

End Sub


Att
Avatar do usuário
Por alexandrevba 26 Jan 2018 às 14:01
Excel Expert
Mensagens: 1643
Reputação: 578
#29752
Boa tarde!

Segue...
Código: Selecionar todosSub teste_guru()
Dim lr As Long
Dim sNomeAbreviado As String
Dim wb As Workbook

lr = Cells(Rows.Count, "A").End(xlUp).Row

With Worksheets("ES0659")
    .Range("AD:AD").Delete
    [AD3].Value = "InsForm"
    .AutoFilterMode = False
    .Range("AD4").Formula = "=INT((TODAY()-S4)/7)" 'Qual é a coluna de data?
    .Range("AD4").AutoFill Destination:=Range("AD4:AD" & lr)
    .Range("D3:AD3").AutoFilter
    .Range("D3:AD3").AutoFilter Field:=27, Criteria1:=">" & 2
    sNomeAbreviado = InputBox("Selecione o Nome Abreviado")
    If sNomeAbreviado = vbNullString Then
        MsgBox ("Busca cancelada")
        .AutoFilterMode = False
        .Range("AD:AD").Delete
        Exit Sub
    End If
    .Range("A3:AC3").AutoFilter Field:=12, Criteria1:=sNomeAbreviado
    .Range("A3:AC" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Worksheets("ATRASO").Range("A1")
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("ATRASO").Copy Before:=wb.Sheets(1)
    wb.SaveAs "C:\Users\Administrador\Downloads\FileAleVBA.xlsx" '<- favor indicar o caminho onde pretende salvar o arquivo
End With

End Sub


Att