Este fórum está sendo desativado

[UbiratanES]

Prezados, obrigado pela atenção.
Como sou novato em programação VBA fiz via gravação de macro, por isso não sei bem o que está na macro.
Então vou explicar a planilha e o que estou precisando:
1) A planilha "Cadastro Participantes" são algumas informações dos participantes;
2) A planilha "Disponibilidade Participantes" é o meu banco de dados com a disponibilidade ou não de cada participante nos dias da semana;
3) A planilha "Filtro" seria justamente para escolher os filtros a serem aplicados na busca.
Usando a função de filtro avançado você precisa usar o mesmo "nome" na célula filtro da célula do "banco de dados".
Por exemplo: Na planilha "Disponibilidade Participantes" a célula D2 tem o nome "SEGUNDA MANHÃ 1" então, na planilha "Filtro" tem que ter uma célula com o nome "SEGUNDA MANHÃ 1".
Só que eu quero colocar um descritivo mais sugestivo para facilitar para o usuário, então pensei em colocar numa parte da planilha "Filtro" os nomes iguais aos da planilha "Disponibilidade Participantes" só que não visíveis (seria o range I1:AE2).
O usuário iria escolher as condições do filtro (B5:E16) e depois clicar em "FILTRAR" e na coluna G, abaixo de "Participantes" iria aparecer os participantes que satisfazem as condições.
Assim pensei: se fizer I2 = B6 e assim sucessivamente está resolvido. Puro engano, o Filtro não funciona.
Esse é o problema que tenho.
Agradeço antecipadamente a ajuda.

[alexandrevba]

Bom dia!!

Como teste, tente adaptar esse código de Ron De Broin
Antes de rodar a macro selecione a guia Disponibilidades Participantes.

Código: Selecionar todos

Sub Copy_With_AutoFilter1()
'Fonte:http://www.rondebruin.nl/win/s3/win006_1.htm
'Ron de Bruin
'Note: This macro use the function LastRow
    Dim My_Range As Range
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim FilterCriteria As String
    Dim FieldCriteria As String
    Dim CCount As Long
    Dim WSNew As Worksheet
    Dim sheetName As String
    Dim rng As Range

    'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
    'and the header of the first column, D is the last column in the filter range.
    'You can also add the sheet name to the code like this :
    'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
    'No need that the sheet is active then when you run the macro when you use this.
    Set My_Range = Range("A1:Y" & LastRow(ActiveSheet))
    My_Range.Parent.Select
    If ActiveWorkbook.ProtectStructure = True Or _
       My_Range.Parent.ProtectContents = True Then
        MsgBox "Desculpe, Nao funciona se o arquivo ou guis estiver protegido", _
               vbOKOnly, "Copiar para uma outra Guia"
        Exit Sub
    End If

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Firstly, remove the AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Filter and set the filter field and the filter criteria :
    'This example filter on the first column in the range (change the field if needed)
    'In this case the range starts in A so Field 1 is column A, 2 = column B, ......
    'Use "<>Netherlands" as criteria if you want the opposite
    '->My_Range.AutoFilter Field:=1, Criteria1:="=Netherlands"

    'If you want to filter on a cell value you can use this, use "<>" for the opposite
    'This example uses the activecell value
    'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value

    'This will use the cell value from A2 as criteria
    'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value

    ''If you want to filter on a Inputbox value use this
    FieldCriteria = InputBox("Qual Coluna deseja filtrar?", "Entre com a coluna.")
    FilterCriteria = InputBox("Qual criterio deseja filtrar?", "Entre com o item.")
    
    My_Range.AutoFilter Field:=FieldCriteria, Criteria1:="=" & FilterCriteria

    'Check if there are not more then 8192 areas(limit of areas that Excel can copy)
    CCount = 0
    On Error Resume Next
    CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
    On Error GoTo 0
    If CCount = 0 Then
        MsgBox "Ha mais do que 8192 areas:" _
             & vbNewLine & "Nao ha como copiar os dados visiveis." _
             & vbNewLine & "Tip: Classifique os dados antes de rodar a macro.", _
               vbOKOnly, "Copiar para uma outra Guia"
    Else
        'Add a new Worksheet
        Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))

        'Ask for the Worksheet name
        sheetName = InputBox("What is the name of the new worksheet?", _
                             "Name the New Sheet")

        On Error Resume Next
        WSNew.Name = sheetName
        If Err.Number > 0 Then
            MsgBox "Altere o nome da guia : " & WSNew.Name & _
                 " manualmente apos rodar essa macro. O nome da guia" & _
                 " ja existe ou contem caracteres nao aceitos" & _
                 " Nao e permitido como nome de guia."
            Err.Clear
        End If
        On Error GoTo 0

        'Copy/paste the visible data to the new worksheet
        My_Range.Parent.AutoFilter.Range.Copy
        With WSNew.Range("A1")
            ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
            ' Remove this line if you use Excel 97
            .PasteSpecial Paste:=8
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
            .Select
        End With

        ' If you want to delete the rows that you copy, also use this
        ' With My_Range.Parent.AutoFilter.Range
        '     On Error Resume Next
        '     Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
        '               .SpecialCells(xlCellTypeVisible)
        '     On Error GoTo 0
        '     If Not rng Is Nothing Then rng.EntireRow.Delete
        ' End With

    End If

    'Close AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    My_Range.Parent.Select
    ActiveWindow.View = ViewMode
    If Not WSNew Is Nothing Then WSNew.Select
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

End Sub


Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Att