Este fórum está sendo desativado

[rit]

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!

[alexandrevba]

Bom dia!!

Talvez isso ajude a ter uma ideia...

Código: Selecionar todos

Sub 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

[rit]

Oi ALe tudo bem ?

Cara deu muito bom, se eu quisesse agora que no final ele salva-se uma pasta ? com o nome que eu escolhi ? como eu faria isso ?

[alexandrevba]

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 todos

Sub 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

[rit]

cara nao consegui fazer funcionar nessa pasta de trablho, desculpa o incomodo mas pode dar uma olhada ?

[alexandrevba]

Boa tarde!

Segue...

Código: Selecionar todos

Sub 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