Saberexcel - o Site das Macros

Essa macro do Aplicativo Microsoft Excel VBA, filtra determinados dados baseados em critérios, enviando os dados para determinado local desejado.

Sub Filtrar_dados()
Range("I13").Select
Range("A1:E5").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"H1:H2"), CopyToRange:=Range("A11:E11"), Unique:=False
Range("F7").Select
End Sub




Aprenda tudo sobre o Aplicativo Microsoft Excel VBA com SabereExcel

SaberExcel - o Site das Macros

Esta macro do Aplicativo Microsoft Excel VBA, contém uma macro que filtra os dados desejados para outra planilha.
Sub Procurar_por_palavra_e_copiar()

Dim vLocalizaLinha As Integer
Dim vCopiaLinha As Integer
Sheets("Plan2").Select
Range("a2:F26").ClearContents
Sheets("Plan1").Select
On Error GoTo Err_Execute

'Inicia busca na linha 4
vLocalizaLinha = 4

'Start copying data to row 2 in Plan2 (row counter variable)
'Comece a copiar dados para linha 2 em Plan2 (linha contariam a variável)
vCopiaLinha = 2

While Len(Range("A" & CStr(vLocalizaLinha)).Value) > 0

'Se valor na coluna E = "Caixa de Correio", copie a linha inteira a Plan2
If Range("E" & CStr(vLocalizaLinha)).Value = Range("H3").Value Then

'selecionando a planilha 1 para copiar
Rows(CStr(vLocalizaLinha) & ":" & CStr(vLocalizaLinha)).Select
Selection.Copy

'colando na planilha 2 na proxima linha
Sheets("Plan2").Select
Rows(CStr(vCopiaLinha) & ":" & CStr(vCopiaLinha)).Select
ActiveSheet.Paste

'Contador move para a proxima linha
vCopiaLinha = vCopiaLinha + 1

'volta para Planilha1 e continua a busca
Sheets("Plan1").Select

End If

vLocalizaLinha = vLocalizaLinha + 1

Wend

'reposiciona na celula (A3)
Application.CutCopyMode = False
Range("A3").Select

MsgBox "todos os dados procurados foram copiados para a Plan2."

Exit Sub

Err_Execute:
MsgBox "ocorreu um erro.", vbInformation, "Saberexcel - o site das macros"

End Sub

Aprenda Aplicativo Microsoft Excel VBA com SaberExcel

SaberExcel - o site das macros
Este exemplo de Funções do Aplicativo Microsoft Excel VBA, filtra dados pela cor e Estilo da Fonte. (Cor e Negrito),
Observe as Funções

=Filtra_Txt_Cores(A2) =(as cores abaixo)

Function Filtra_Txt_Cores(sb As Range)
Application.Volatile
Select Case sb.Font.ColorIndex
Case 3
Filtra_Txt_Cores = "Vermelho"
Case 4
Filtra_Txt_Cores = "Verde"
Case 1
Filtra_Txt_Cores = "Preto"
Case 2
Filtra_Txt_Cores = "Branco"
Case Else
Filtra_Txt_Cores = "outras cores"
End Select
End Function

Essa função retorna se a fonte esta normal ou negritada.
=Negrito(C12)

Function Negrito(sb As Range)
Application.Volatile
Negrito = IIf(sb.Font.Bold, "Negrito", "Normal")
End Function


Aprenda Microsoft Excel VBA -- com Saberexcel
sozinho, em casa, com baixo custo,

Esse procedimento do Aplicativo Microsoft Excel VBA, insere cor no cabeçalho da tabela onde é aplicado o autofiltro, com auxilio de combobox com cores relacionadas.

Option Explicit

Private Sub Worksheet_Calculate()
Dim sb As AutoFilter
Dim vFiltro As Filter
Dim vFiltroContador As Integer

If ActiveSheet.AutoFilterMode Then
Set sb = ActiveSheet.AutoFilter
vFiltroContador = 1
For Each vFiltro In sb.Filters
If vFiltro.On Then
sb.Range.Cells(1, vFiltroContador) _
.Interior.ColorIndex = Range("color")

Else
sb.Range.Cells(1, vFiltroContador) _
.Interior.ColorIndex = xlNone
End If
vFiltroContador = vFiltroContador + 1
Next vFiltro
Else
Rows(1).EntireRow.Interior.ColorIndex = xlNone
End If
End Sub


Aprenda tudo sobre o Aplicativo Microsoft Excel VBA - com Saberexcel

Saberexcel - site das macros
Esta Macro do Aplicativo Microsoft Excel VBA, separa determinados dados e transfere para outra planilha

Option Explicit

Sub Transfere_Transforma_Dados()
Dim vLivro As Workbook
Dim vPlanDados As Worksheet, vPlanAuxiliar As Worksheet
Dim vRangeUnica As Range, vRangeInicial As Range, rnData As Range
Dim rnFilter As Range, rnFind As Range, rnSource As Range
Dim vaField As Variant
Dim i As Long, j As Long

Set vLivro = ThisWorkbook

With vLivro
Set vPlanDados = .Worksheets("Pagamento")
Set vPlanAuxiliar = .Worksheets("Auxiliar")
End With

With vPlanDados
Set vRangeUnica = .Range(.Range("C1"), .Range("C65536").End(xlUp))
Set rnSource = .Range(.Range("C2"), .Range("C65536").End(xlUp))
Set rnFilter = .Range(.Range("A1"), .Range("D65536").End(xlUp))
Set rnData = .Range("A1")
End With

With vPlanAuxiliar
Set vRangeInicial = .Range("A1")
End With

Application.ScreenUpdating = False

'First we sort the table.
rnFilter.Sort Key1:=Range("C2"), _
Order1:=xlAscending, _
Header:=xlGuess, _
Ordercustom:=1, _
MatchCase:=True, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' Then we create the unique collection of fieldnames.
vRangeUnica.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=vRangeUnica, _
CopyToRange:=Range("J1"), _
Unique:=True

'Read the unique collection into an array.
With vPlanDados
vaField = .Range(.Range("J2"), .Range("J65536").End(xlUp))
End With

With vRangeInicial
.Value = "Request_ID"
'Add the collection to the first row in the target-worksheet.
.Offset(0, 1).Resize(1, UBound(vaField)).Value = Application.Transpose(vaField)
'Add the Request-ID numbers to the first column in the target-worksheet.
.Offset(1, 0).Resize(vRangeUnica.Rows.Count, 1).Value = vRangeUnica.Offset(1, -2).Value
End With

'Loop through the collection, set the condition and finally
'transfer the data into the target-worksheet.

For i = 1 To UBound(vaField)
rnData.AutoFilter Field:=3, Criteria1:=vaField(i, 1)
Set rnFind = rnSource.SpecialCells(xlCellTypeVisible)
j = rnFind.Rows.Count
vRangeInicial.Offset(1, i).Resize(j, 1).Value = rnFind.Offset(0, 1).Value
Next i

vPlanDados.AutoFilterMode = False

Application.ScreenUpdating = False

MsgBox "Concluido"

End Sub

Aprenda tudo sobre o Aplicativo Microsoft Excel VBA, sozinho, praticando com os produtos didáticos Saberexcel