Ir ao conteúdo
  • Cadastre-se
ppeterk

Excel VBA - filtrar dados e salvar

Recommended Posts

Amigos, bom dia!

Preciso muito da ajuda de vocês. Procurei, mas não encontrei algo que eu conseguisse adaptar. Vamos lá:

 

Eu preciso de um código que simplesmente filtre um dado em comum em todas as abas/sheets do arquivo e depois salve. Retorna novamente e filtre o próximo dado em comum de todas as abas/sheets e salva.

(Exemplo: Na coluna B da aba1/sheet1 tem o código "1001", assim como na aba2/sheet2 tem, também, na coluna B o código 1001 e assim vai)

 

 

Tenho esse código abaixo que o usuário cria um arquivo excel e atrela a macro a um botão e, quando ele clica no botão, acontece o seguinte:

 

1 - Solicita o usuário o arquivo que ele quer realizar esses filtros em todas a abas.

 

2 - O local onde ele quer salvar todos os arquivos que serão geradas ao filtrar código por código (Exemplo: realiza o filtro com o código 1001 da coluna B de todas as abas/sheets; esse arquivo com os dados do código 1001 terá um nome. Quando realizar o filtro com o código 1002 uma novo arquivo com um novo nome surgirá).

 

3 - Peço o usuário para digitar o nome padrão/inicial que ele quer para todas os arquivos que serão geradas (Digo isso, pois eu peço para completar o nome com um conteúdo em uma Range)

4 - Por fim, e mais importante, ao dar OK esse LOOP dos filtros deverá iniciar (Aqui que eu preciso da ajuda de vocês).

'FUNÇÃO PARA ABRIR O ARQUIVO QUE ELE QUER
Public Function OpenFileDialog() As String
    Dim Filter As String, Title As String
    Dim FilterIndex As Integer
    Dim Filename As Variant
    ' Define o filtro de procura dos arquivos
    Filter = "Arquivos Excel (*.xlsx),*.xlsx,"
    ' O filtro padrão é *.*
    FilterIndex = 3
    ' Define o Título (Caption) da Tela
    Title = "Selecione um arquivo"
    ' Define o disco de procura
    ChDrive ("S")
    ChDir ("S:\")
    With Application
        ' Abre a caixa de diálogo para seleção do arquivo com os parâmetros
        Filename = .GetOpenFilename(Filter, FilterIndex, Title)
        ' Reseta o Path
        ChDrive (Left(.DefaultFilePath, 1))
        ChDir (.DefaultFilePath)
    End With
    ' Abandona ao Cancelar
    If Filename = False Then
        MsgBox "Nenhum arquivo foi selecionado."
        Exit Function
    End If
    ' Retorna o caminho do arquivo
    OpenFileDialog = Filename

End Function

'--------------------------------------------------------------------------------------------------------------------------
'FUNÇÃO PARA SELECIONAR O CAMINHO

Function localizarCaminho()

Dim strCaminho As String

With Application.FileDialog(msoFileDialogFolderPicker)

'Permitir mais de uma pasta
.AllowMultiSelect = False

'Mostrar janela
.Show

If .SelectedItems.Count > 0 Then
strCaminho = .SelectedItems(1)
End If

End With

'Atribuir caminho a variável
modFileBrowser = strCaminho
localizarCaminho = modFileBrowser

End Function

'--------------------------------------------------------------------------------------------------------------------------
Sub Retângulo1_Clique()


'PLANILHA QUE ELE QUER

MsgBox "Selecione a planilha a ser quebrada"
nameFile = OpenFileDialog()

'LOCAL QUE ELE QUER


MsgBox "Selecione o local a ser gravado"
localFile = localizarCaminho()
MsgBox localFile

'ESCOLHE O NOME QUE ELE QUER

varTexto = InputBox("Exemplo: 'Orçado x Realizado 01 2018'", "Nome padrão para planilhas")


   '--------------------------------------------------------------------------------------------------------------------------
   'AQUI COMEÇA O LOOP EM CADA SHEET

  Workbooks.Open nameFile


  Worksheets(1).Activate
   
'Ex: Apaga tudo e deixa apenas o código 1001 da coluna B

      Worksheets(2).Activate

'Ex: Apaga tudo e deixa apenas o código 1001 da coluna B

    Worksheets(3).Activate

'Ex: Apaga tudo e deixa apenas o código 1001 da coluna B

    Worksheets(4).Activate

'Ex: Apaga tudo e deixa apenas o código 1001 da coluna B

    Worksheets(5).Activate

'Ex: Apaga tudo e deixa apenas o código 1001 da coluna B

     Worksheets(6).Activate

'Ex: Apaga tudo e deixa apenas o código 1001 da coluna B
   

'AQUI SALVA COM O NOME INICIAL QUE ELE COLOCOU E O RESTO EU DIGO QUE É PARA COMPLETAR COM A RANGE C2

    ActiveWorkbook.SaveAs Filename:= _
        varTexto & " - " & Range("A2").Text & " - " & Range("C2").Text & ".xlsx"

   
    ActiveWorkbook.Close savechanges:=True
    Application.DisplayAlerts = True
   
   
        End Sub

 

Obs: Coloquei em anexo um exemplo de arquivo que em todas as abas/sheets, na coluna B, tem código em comum (1001, 1002, 1003, 1004).

Planilha para Filtrar e Salvar.xlsx

Compartilhar este post


Link para o post
Compartilhar em outros sites
17 horas atrás, CasaDoHardware disse:

Juro nao entendi a duvida!

Qual  problema neste seu codigo?

CasaDoHardware, obrigado pelo retorno e desculpe se não expliquei bem. O código está certo. Acho que era melhor não postá-lo para não causar mais confusão.

 

Em suma meu problema é: Não sei fazer uma macro que separa o arquivo de acordo com um critério (Critério esse que se encontra na coluna B). Só isso!

 

De qualquer forma, eu fucei em alguns lugares e encontrei um código que me atende. Agradeço muito pela atenção. Segue o código que me atendeu:

Dim i As Variant
    Dim aStrings(1 To 121) As Double  'variável contendo 121 variáveis
    
aStrings(1) = 1001
aStrings(2) = 1002
aStrings(3) = 1003
aStrings(4) = 1004
aStrings(5) = 1007
aStrings(6) = 1008
aStrings(7) = 1009
aStrings(8) = 1010
aStrings(9) = 1011
aStrings(10) = 1012
aStrings(11) = 1013
aStrings(12) = 1014
aStrings(13) = 1015
aStrings(14) = 1016
aStrings(15) = 1017
aStrings(16) = 2001
aStrings(17) = 2002
aStrings(18) = 2003
aStrings(19) = 2004
aStrings(20) = 2005
aStrings(21) = 2006
aStrings(22) = 2007
aStrings(23) = 2008
aStrings(24) = 2009
aStrings(25) = 2010
aStrings(26) = 2013
aStrings(27) = 3001
aStrings(28) = 3002
aStrings(29) = 3003
aStrings(30) = 3004
aStrings(31) = 3005
aStrings(32) = 3006
aStrings(33) = 3007
aStrings(34) = 3008
aStrings(35) = 3009
aStrings(36) = 3010
aStrings(37) = 3011
aStrings(38) = 3012
aStrings(39) = 3013
aStrings(40) = 3014
aStrings(41) = 3015
aStrings(42) = 3016
aStrings(43) = 3017
aStrings(44) = 3018
aStrings(45) = 3019
aStrings(46) = 3020
aStrings(47) = 3021
aStrings(48) = 3022
aStrings(49) = 3023
aStrings(50) = 3024
aStrings(51) = 3025
aStrings(52) = 3026
aStrings(53) = 3027
aStrings(54) = 3028
aStrings(55) = 3029
aStrings(56) = 3030
aStrings(57) = 3031
aStrings(58) = 3032
aStrings(59) = 3033
aStrings(60) = 3034
aStrings(61) = 3035
aStrings(62) = 3036
aStrings(63) = 3037
aStrings(64) = 3038
aStrings(65) = 3039
aStrings(66) = 3045
aStrings(67) = 3051
aStrings(68) = 3052
aStrings(69) = 3053
aStrings(70) = 3054
aStrings(71) = 4001
aStrings(72) = 4002
aStrings(73) = 4003
aStrings(74) = 4005
aStrings(75) = 4006
aStrings(76) = 4007
aStrings(77) = 4008
aStrings(78) = 4009
aStrings(79) = 4010
aStrings(80) = 4011
aStrings(81) = 4012
aStrings(82) = 4013
aStrings(83) = 4014
aStrings(84) = 4015
aStrings(85) = 4016
aStrings(86) = 4017
aStrings(87) = 4018
aStrings(88) = 4019
aStrings(89) = 4020
aStrings(90) = 4021
aStrings(91) = 4022
aStrings(92) = 4023
aStrings(93) = 4024
aStrings(94) = 4025
aStrings(95) = 4026
aStrings(96) = 4027
aStrings(97) = 4028
aStrings(98) = 4029
aStrings(99) = 4030
aStrings(100) = 4031
aStrings(101) = 4032
aStrings(102) = 4033
aStrings(103) = 4034
aStrings(104) = 4035
aStrings(105) = 4036
aStrings(106) = 4038
aStrings(107) = 4039
aStrings(108) = 4040
aStrings(109) = 4041
aStrings(110) = 4042
aStrings(111) = 4043
aStrings(112) = 4044
aStrings(113) = 4045
aStrings(114) = 4046
aStrings(115) = 4047
aStrings(116) = 4048
aStrings(117) = 4049
aStrings(118) = 4050
aStrings(119) = 4051
aStrings(120) = 4053
aStrings(121) = 4054

    For Each i In aStrings  ' for para fazer fazer o loop de variável por variável

Workbooks.Open nameFile  'abrir arquivo que ele deve realizar a macro

  Worksheets(1).Activate  'ativa a sheet1/aba1

    Dim lRow As Long
    Dim lCount As Long
    Dim lLast As Long


    With Sheets(1)
        lLast = .Cells(.Rows.Count, "B").End(xlUp).Row     'percorre até a última linha
        For lRow = lLast To 2 Step -1                     
            If .Cells(lRow, "B") <> i Then        ' se diferente de i começa a apagar da última até a primeira  
                .Rows(lRow).Delete                
                lCount = lCount + 1
            End If
        Next lRow
    End With
  

Worksheets(2).Activate    'ativa a sheet2/aba2


    Dim lRow1 As Long
    Dim lCount1 As Long
    Dim lLast1 As Long

    With Sheets(2)
        lLast1 = .Cells(.Rows.Count, "B").End(xlUp).Row     'percorre até a última linha
        For lRow1 = lLast1 To 2 Step -1
            If .Cells(lRow1, "B") <> i Then     ' se diferente de i começa a apagar da última até a primeira 
                .Rows(lRow1).Delete
                lCount1 = lCount1 + 1
            End If
        Next lRow1
    End With


ActiveWorkbook.SaveAs Filename:= _         'localFile: Local que o usuário escolheu - varTexto: Nome que o usuário deseja
        localFile & "\" & varTexto & " - " & Range("A2").Text & " - " & Range("C2").Text & ".xlsx"

        
    ActiveWorkbook.Close savechanges:=True
    Application.DisplayAlerts = False 'Subistituir sem dó
        
       
    Next i

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×