Este fórum está sendo desativado

Depois de 9 anos, este fórum será desativado. Mas calma.... estamos migrando para uma comunidade no DISCORD. Junte-se a nós.

ENTRAR PARA DISCORD

Ajuda com Userform filtro VBA

Tópicos relacionados a códigos VBA, gravação de macros, etc.
 Resposta

Ajuda com Userform filtro VBA

Por ICEFROG
Posts
-  11 Jun 2022 às 09:48 #71288
Fala pessoal,

Precisava da vossa ajudar em estruturar este userform, não sei bem como fazer da forma mais correta, assim como não tenho muito experiencia.

Recomendo testarem a planilha para verem a fluidez.

Basicamente o que tenho tentado fazer e o seguinte:

MARCA DE CARROS, CORES e ANIMAIS, Dentro de cada uma destas tem um subcategoria que vai ser usado no ListBox para ser selecionado individualmente, atualmente so esta a filtrar as estas categorias porque tenho dificuldades em progredir.

Minha ideia e fazer com que baseado no dia , exemplo: se no dia 12/06/2022 tiver apenas "BMW", "MERCEDES", "TOYOTA", na Listbox aparece so o que foi filtrado no caso "BMW", "MERCEDES", "TOYOTA" para selecionar, entao eu posso escolher apenas "BMW" e na lista que for imprimir ser filtrado apenas o que foi selecionado.


Outra coisa para teste o filtro estava a mudar consoante o que o usuario seleciona(data, tipo e planilha), gostaria tambem que fosse possivel apenas quando o usuario aperta o "OK"

obrigado.

Código: Selecionar todos
Option Explicit

Dim rngM As Range, rngT As Range, rngN As Range, rngmra As Range, rngtra As Range, rngnra As Range
Dim rngmrp As Range, rngtrp As Range, rngnrp As Range
Dim rngmrn As Range, rngtrn As Range, rngnrn As Range
Dim msg1 As Integer, msg2 As Integer
Dim wsM As Worksheet, wsT As Worksheet, wsN As Worksheet
Dim wsmra As Worksheet, wstra As Worksheet, wsnra As Worksheet
Dim wsmrp As Worksheet, wstrp As Worksheet, wsnrp As Worksheet
Dim wsmrn As Worksheet, wstrn As Worksheet, wsnrn As Worksheet



Sub CBDA_Change()

    Set wsM = Sheets("SHEET1")
    Set wsT = Sheets("SHEET2")
    Set wsN = Sheets("SHEET3")
    
    Set rngM = wsM.Range("B4:N" & wsM.Range("B" & Rows.Count).End(xlUp).Row)
    Set rngT = wsT.Range("B3:N" & wsT.Range("B" & Rows.Count).End(xlUp).Row)
    Set rngN = wsN.Range("B3:N" & wsN.Range("B" & Rows.Count).End(xlUp).Row)



    If LISTAGEM.CBTU.Value = "SHEET1" And LISTAGEM.CBDA.Value = Format(Date, "dd/MM/YY") Then
   
        rngM.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngM.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        
    ElseIf LISTAGEM.CBTU.Value = "SHEET1" And LISTAGEM.CBDA.Value = Format(Date + 1, "dd/MM/YY") Then
   
        rngM.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngM.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        
    End If



    If LISTAGEM.CBDA.Value = Format(Date, "dd/MM/YY") And LISTAGEM.CBTU.Value = "SHEET2" Then
   
        rngT.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngT.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        
    ElseIf LISTAGEM.CBDA.Value = Format(Date + 1, "dd/MM/YY") And LISTAGEM.CBTU.Value = "SHEET2" Then
   
        rngT.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngT.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        
    End If
    



    If LISTAGEM.CBDA.Value = Format(Date, "dd/MM/YY") And LISTAGEM.CBTU.Value = "SHEET3" Then
   
        rngN.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngN.AutoFilter 2, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
        
    ElseIf LISTAGEM.CBDA.Value = Format(Date + 1, "dd/MM/YY") And LISTAGEM.CBTU.Value = "SHEET3" Then
   
        rngN.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngN.AutoFilter 2, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic
        
    End If
   

End Sub



Sub CBTI_Change()

    Set wsM = Sheets("SHEET1")
    Set wsT = Sheets("SHEET2")
    Set wsN = Sheets("SHEET3")
    
    Set rngM = wsM.Range("B4:N" & wsM.Range("B" & Rows.Count).End(xlUp).Row)
    Set rngT = wsT.Range("B3:N" & wsT.Range("B" & Rows.Count).End(xlUp).Row)
    Set rngN = wsN.Range("B3:N" & wsN.Range("B" & Rows.Count).End(xlUp).Row)


    If LISTAGEM.CBTI.Value = "MARCA DE CARROS" And LISTAGEM.CBTU.Value = "SHEET1" Then
   
        rngM.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngM.AutoFilter 6, Criteria1:="MARCA DE CARROS", Operator:=xlFilterValues
        
    ElseIf LISTAGEM.CBTI.Value = "CORES" And LISTAGEM.CBTU.Value = "SHEET1" Then
    
        rngM.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngM.AutoFilter 6, Criteria1:="CORES", Operator:=xlFilterValues
    End If
        
    If LISTAGEM.CBTI.Value = "ANIMAIS" And LISTAGEM.CBTU.Value = "SHEET1" Then
    
        rngM.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngM.AutoFilter 6, Criteria1:="ANIMAIS", Operator:=xlFilterValues
        
    End If





    If LISTAGEM.CBTI.Value = "MARCA DE CARROS" And LISTAGEM.CBTU.Value = "SHEET2" Then
   
        rngT.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngT.AutoFilter 6, Criteria1:="MARCA DE CARROS", Operator:=xlFilterValues
        
    ElseIf LISTAGEM.CBTI.Value = "CORES" And LISTAGEM.CBTU.Value = "SHEET2" Then
   
        rngT.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngT.AutoFilter 6, Criteria1:="CORES", Operator:=xlFilterValues
        
    ElseIf LISTAGEM.CBTI.Value = "ANIMAIS" And LISTAGEM.CBTU.Value = "SHEET2" Then
   
        rngT.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngT.AutoFilter 6, Criteria1:="ANIMAIS", Operator:=xlFilterValues
        
    End If




    If LISTAGEM.CBTI.Value = "MARCA DE CARROS" And LISTAGEM.CBTU.Value = "SHEET3" Then
   
        rngN.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngN.AutoFilter 6, Criteria1:="MARCA DE CARROS", Operator:=xlFilterValues
        
    ElseIf LISTAGEM.CBTI.Value = "CORES" And LISTAGEM.CBTU.Value = "SHEET3" Then
   
        rngN.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngN.AutoFilter 6, Criteria1:="CORES", Operator:=xlFilterValues
        
    ElseIf LISTAGEM.CBTI.Value = "ANIMAIS" And LISTAGEM.CBTU.Value = "SHEET3" Then
   
        rngN.AutoFilter 1, Criteria1:="TRUE", Operator:=xlFilterValues
        rngN.AutoFilter 6, Criteria1:="ANIMAIS", Operator:=xlFilterValues
        
    End If
End Sub


Private Sub LBSE_Formato()
    LBSE.MultiSelect = fmMultiSelectMulti
    LBSE.ListStyle = fmListStyleOption
End Sub


Private Sub CBTI_Click()

Dim AMB_LISTA As String, FRE_LISTA As String, CON_LISTA As String

If LISTAGEM.CBTI.Value = "MARCA DE CARROS" Then

    LBSE.List = Array("BMW", "MERCEDES", "TOYOTA", "TESLA", "FERRARI")
    
ElseIf LISTAGEM.CBTI.Value = "ANIMAIS" Then


    LBSE.List = Array("GATO", "CÃO", "PATO", "PAPAGAIO", "TUCANO")
    
ElseIf LISTAGEM.CBTI.Value = "CORES" Then

    LBSE.List = Array("AZUL", "VERMELHO", "AMARELO", "VERDE", "CINZA")
End If

End Sub




Private Sub SUBMETERLIST_Click()

If LISTAGEM.SUBMETERLIST = LISTAGEM.SUBMETERLIST Then

Call IMPRIMIR_LISTAGEM

Unload Me

End If

End Sub


Sub UserForm_Initialize()

Dim CBdata1 As String, CBdata2 As String
CBdata1 = Format(Date, "dd/MM/YY")
CBdata2 = Format(Date + 1, "dd/MM/YY")
    CBDA.AddItem CBdata1
    CBDA.AddItem CBdata2
    CBTU.AddItem "SHEET1"
    CBTU.AddItem "SHEET2"
    CBTU.AddItem "SHEET3"
    CBTI.AddItem "MARCA DE CARROS"
    CBTI.AddItem "CORES"
    CBTI.AddItem "ANIMAIS"
End Sub
CODIGO:
Código: Selecionar todos
Sub mostrar_forms()
LISTAGEM.Show
End Sub

Sub IMPRIMIR_LISTAGEM()

 Dim MAws As Worksheet, TAws As Worksheet, NOws As Worksheet
 
 Dim REMAws As Worksheet, RETAws As Worksheet, RENOws As Worksheet
 
 Dim MArng As Range, TArng As Range, NOrng As Range
 
 Dim REMArng As Range, RETArng As Range, RENOrng As Range
 
 Dim msg As Integer
 

    Set MAws = Sheets("SHEET1")
    Set TAws = Sheets("SHEET2")
    Set NOws = Sheets("SHEET3")
    

    Set REMAws = Sheets("SHEET1PRINT")
    Set RETAws = Sheets("SHEET2PRINT")
    Set RENOws = Sheets("SHEET3PRINT")
    

    Set MArng = MAws.Range("B4:N" & MAws.Range("B" & Rows.Count).End(xlUp).Row)
    Set TArng = TAws.Range("B4:N" & TAws.Range("B" & Rows.Count).End(xlUp).Row)
    Set NOrng = NOws.Range("B4:N" & NOws.Range("B" & Rows.Count).End(xlUp).Row)
    
    Set REMArng = REMAws.Range("B3")
    Set RETArng = RETAws.Range("B3")
    Set RENOrng = RENOws.Range("B3")

REMAws.Cells.Clear
RETAws.Cells.Clear
RENOws.Cells.Clear

Application.ScreenUpdating = False



  
If MAws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "MARCA DE CARROS" _
    And LISTAGEM.CBTU.Value = "SHEET1" Then
    REMAws.Visible = xlSheetVisible
    REMAws.Activate
    MArng.SpecialCells(xlCellTypeVisible).Copy REMArng
    REMAws.Range("F3", REMAws.Range("F3").End(xlDown)).Sort Key1:=REMAws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    REMAws.UsedRange.EntireRow.EntireColumn.AutoFit
    REMAws.Columns(2).EntireColumn.Hidden = True
    REMAws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If
If MAws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "CORES" _
    And LISTAGEM.CBTU.Value = "SHEET1" Then
    REMAws.Visible = xlSheetVisible
    REMAws.Activate
    MArng.SpecialCells(xlCellTypeVisible).Copy REMArng
    REMAws.Range("F3", REMAws.Range("F3").End(xlDown)).Sort Key1:=REMAws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    REMAws.UsedRange.EntireRow.EntireColumn.AutoFit
    REMAws.Columns(2).EntireColumn.Hidden = True
    REMAws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If
If MAws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "ANIMAIS" _
    And LISTAGEM.CBTU.Value = "SHEET1" Then
    REMAws.Visible = xlSheetVisible
    REMAws.Activate
    MArng.SpecialCells(xlCellTypeVisible).Copy REMArng
    REMAws.Range("F3", REMAws.Range("F3").End(xlDown)).Sort Key1:=REMAws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    REMAws.UsedRange.EntireRow.EntireColumn.AutoFit
    REMAws.Columns(2).EntireColumn.Hidden = True
    REMAws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If

'''' sheet2

If TAws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "MARCA DE CARROS" _
    And LISTAGEM.CBTU.Value = "SHEET2" Then
    RETAws.Visible = xlSheetVisible
    RETAws.Activate
    TArng.SpecialCells(xlCellTypeVisible).Copy RETArng
    RETAws.Range("F3", RETAws.Range("F3").End(xlDown)).Sort Key1:=RETAws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    RETAws.UsedRange.EntireRow.EntireColumn.AutoFit
    RETAws.Columns(2).EntireColumn.Hidden = True
    RETAws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If
If TAws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "CORES" _
    And LISTAGEM.CBTU.Value = "SHEET2" Then
    RETAws.Visible = xlSheetVisible
    RETAws.Activate
    TArng.SpecialCells(xlCellTypeVisible).Copy RETArng
    RETAws.Range("F3", RETAws.Range("F3").End(xlDown)).Sort Key1:=RETAws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    RETAws.UsedRange.EntireRow.EntireColumn.AutoFit
    RETAws.Columns(2).EntireColumn.Hidden = True
    RETAws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If
If TAws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "ANIMAIS" _
    And LISTAGEM.CBTU.Value = "SHEET2" Then
    RETAws.Visible = xlSheetVisible
    RETAws.Activate
    TArng.SpecialCells(xlCellTypeVisible).Copy RETArng
    RETAws.Range("F3", RETAws.Range("F3").End(xlDown)).Sort Key1:=RETAws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    RETAws.UsedRange.EntireRow.EntireColumn.AutoFit
    RETAws.Columns(2).EntireColumn.Hidden = True
    RETAws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If

'''' sheet3

If NOws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "MARCA DE CARROS" _
    And LISTAGEM.CBTU.Value = "SHEET3" Then
    RENOws.Visible = xlSheetVisible
    RENOws.Activate
    NOrng.SpecialCells(xlCellTypeVisible).Copy RENOrng
    RENOws.Range("F3", RENOws.Range("F3").End(xlDown)).Sort Key1:=RENOws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    RENOws.UsedRange.EntireRow.EntireColumn.AutoFit
    RENOws.Columns(2).EntireColumn.Hidden = True
    RENOws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If
If NOws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "CORES" _
    And LISTAGEM.CBTU.Value = "SHEET3" Then
    RENOws.Visible = xlSheetVisible
    RENOws.Activate
    NOrng.SpecialCells(xlCellTypeVisible).Copy RENOrng
    RENOws.Range("F3", RENOws.Range("F3").End(xlDown)).Sort Key1:=RENOws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    RENOws.UsedRange.EntireRow.EntireColumn.AutoFit
    RENOws.Columns(2).EntireColumn.Hidden = True
    RENOws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If
If NOws.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Count > 1 _
    And LISTAGEM.CBTI.Value = "ANIMAIS" _
    And LISTAGEM.CBTU.Value = "SHEET3" Then
    RENOws.Visible = xlSheetVisible
    RENOws.Activate
    NOrng.SpecialCells(xlCellTypeVisible).Copy RENOrng
    RENOws.Range("F3", RENOws.Range("F3").End(xlDown)).Sort Key1:=RENOws.Range("F3"), Order1:=xlAscending, Header:=xlYes
    RENOws.UsedRange.EntireRow.EntireColumn.AutoFit
    RENOws.Columns(2).EntireColumn.Hidden = True
    RENOws.Columns(7).EntireColumn.Hidden = True
    Tabelacab
End If

    Application.CutCopyMode = False
    Application.ScreenUpdating = True

    On Error Resume Next
        MAws.ShowAllData
        TAws.ShowAllData
        NOws.ShowAllData
    On Error GoTo 0
    
'REMAws.Visible = xlSheetVeryHidden
'RETAws.Visible = xlSheetVeryHidden
'RENOws.Visible = xlSheetVeryHidden

End Sub




Sub Tabelacab()

Dim rngMERGE1 As Range, rngMERGE2 As Range, rngMERGE3 As Range, rngMERGE4 As Range
Dim Text1 As String, Text2 As String, Text3 As String, Text4 As String
Dim ws As Worksheet

Text1 = "HOLDER " & LISTAGEM.CBTU.Value & " / " & LISTAGEM.CBTI.Value
Text2 = ""
Text3 = "HOLDER " & LISTAGEM.CBDA
Text4 = "HOLDER"



Set rngMERGE1 = Range("C1:F1")
Set rngMERGE2 = Range("F1:F1")
Set rngMERGE3 = Range("C2:L2")
Set rngMERGE4 = Range("M2:N2")

For Each ws In Sheets(Array("SHEET1PRINT", "SHEET2PRINT", "SHEET3PRINT"))

With ws

    With rngMERGE1
        .Merge
        .Value = Text1
        .Font.Bold = True
        .Font.Name = "Calibri"
        .Font.Size = 12
        .WrapText = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Interior.ColorIndex = 0
        .BorderAround , LineStyle:=xlContinuous, Weight:=xlThick
    End With
    


    With rngMERGE3
       .Merge
       .Value = Text3
       .Font.Bold = True
       .Font.Name = "Calibri"
       .Font.Size = 12
       .WrapText = True
       .HorizontalAlignment = xlCenter
       .VerticalAlignment = xlCenter
       .Interior.ColorIndex = 35
       .BorderAround , LineStyle:=xlContinuous, Weight:=xlThick
    End With
    
        With rngMERGE4
       .Merge
       .Value = Text4
       .Font.Bold = True
       .Font.Name = "Calibri"
       .Font.Size = 11
       .WrapText = True
       .HorizontalAlignment = xlCenter
       .VerticalAlignment = xlCenter
       .Interior.ColorIndex = 15
       .BorderAround , LineStyle:=xlContinuous, Weight:=xlThick
    End With

End With
Next ws

End Sub
planilhada adicionada
Você não está autorizado a ver ou baixar esse anexo.
 Resposta
 Voltar para “Macros e VBA”
long long title how many chars? lets see 123 ok more? yes 60

We have created lots of YouTube videos just so you can achieve [...]

READ MORE
Another post test yes yes yes or no, maybe ni? :-/

The best flat phpBB theme around. Period. Fine craftmanship and [...]

READ MORE
Do you need a super MOD? Well here it is. chew on this

All you need is right here. Content tag, SEO, listing, Pizza and spaghetti [...]

READ MORE
Lasagna on me this time ok? I got plenty of cash

this should be fantastic. but what about links,images, bbcodes etc etc? [...]

READ MORE

Estamos migrando para uma comunidade no Discord

ENTRAR PARA DISCORD