Boa noite!!
Vou deixar as feras responder em meu lugar, pois ainda não entendi.
A não ser que eu esteja enganado, mas o código abaixo apenas filtra baseado em critério as colunas A,B e C.
E não faz o que você descreveu abaixo.
O filtro localiza na coluna H6:H21, os "x" e copia os valores correspondente ao "x" no intervalo I6:K21 e cola em P6:R21.
Sub Filtrar()
'With Application
' .ScreenUpdating = False
' .DisplayAlerts = False
'End With
'On Error Resume Next
If Range("A1") = "AAA" Then filtro = 1
If Range("A1") = "BBB" Then filtro = 2
If Range("A1") = "CCC" Then filtro = 3
If Range("A1") = "DDD" Then filtro = 4
If Range("A1") = "EEE" Then filtro = 5
If Range("A1") = "FFF" Then filtro = 6
Select Case filtro
Case 1
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=1, Criteria1:="AAA"
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=2, Criteria1:="<>"
Range("B22:C22").Select
Selection.Copy
Range("A27").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Case 2
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=1, Criteria1:="BBB"
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=2, Criteria1:="<>"
Range("B22:C22").Select
Selection.Copy
Range("A28").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Case 3
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=1, Criteria1:="CCC"
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=2, Criteria1:="<>"
Range("B22:C22").Select
Selection.Copy
Range("A29").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Case 4
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=1, Criteria1:="DDD"
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=2, Criteria1:="<>"
Range("B22:C22").Select
Selection.Copy
Range("A30").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Case 5
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=1, Criteria1:="EEE"
ActiveSheet.Range("$A$1:$c$21").AutoFilter Field:=2, Criteria1:="<>"
Range("B22:C22").Select
Selection.Copy
Range("A31").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Case 6
ActiveSheet.ShowAllData
End Select
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 20/04/2013 7:11 pm