Excel VBA - filtrar dados e salvar

ppeterk · 20 de junho de 2018

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

ppeterk · 3 de julho de 2018

Alguém?

CasaDoHardware · 3 de julho de 2018

Juro nao entendi a duvida!

Qual problema neste seu codigo?

ppeterk · 4 de julho de 2018

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