Saberexcel - O site de quem precisa aprender macros Microsoft Excel VBA

Esse macro do Aplicativo Microsoft Excel VBA(Visual Basic Application), filtra determinados ítens de uma tabela da folha de Planilha principal, para as referidas folhas de planilhas conforme critério na tabela, isto é, distribui dados para as folhas de planilhas correspondentes, filtrando os dados.
Observe que o macro monta os cabeçalhos e retorna os dados relacionados a folha de planilha, montando um relatório para cada ítem e também
organiza na ordem crescente por data, há uma subrotina para essa finalidade, chamada Sub Ordenar_Dados(Argumentos).

Option Explicit
Dim vTabela_Recap() As Variant

Sub Distribuir_dados_planilhas()
Dim Tableau_Recup As Variant

Dim L As Integer, Item As Integer, vUltimaLinha As Integer, x As Integer
Dim Col As Byte, vUltimaColuna As Byte
Dim vNomePlanilha As String
Dim vColecaoPlanilhas As Collection
Dim vTabela_Cabecalho(4) As Variant

vTabela_Cabecalho(0) = "DATA"
vTabela_Cabecalho(1) = "NOME-SOBRENOME"
vTabela_Cabecalho(2) = "PLANILHA"
vTabela_Cabecalho(3) = "PRE-INSRIÇÃO"

Set vColecaoPlanilhas = New Collection
x = -1
With Worksheets("Dados")
vUltimaLinha = .Range("A65536").End(xlUp).Row
vUltimaColuna = .Range("IV7").End(xlToLeft).Column
Tableau_Recup = .Range(.Cells(7, 1), .Cells(vUltimaLinha, vUltimaColuna))
On Error Resume Next
For L = 2 To UBound(Tableau_Recup, 1)
vColecaoPlanilhas.Add Tableau_Recup(L, 3), CStr(Tableau_Recup(L, 3))
Next
On Error GoTo 0
Err.Clear
End With
Application.ScreenUpdating = False
For L = 1 To vColecaoPlanilhas.Count

vNomePlanilha = vColecaoPlanilhas(L)

With Worksheets(vNomePlanilha)
vUltimaLinha = .Range("A65536").End(xlUp).Row + 1
vUltimaColuna = .Range("IV7").End(xlToLeft).Column
.Range(.Cells(6, 1), .Cells(vUltimaLinha, vUltimaColuna)).ClearContents
For Item = 1 To UBound(Tableau_Recup, 1)
If vColecaoPlanilhas(L) = Tableau_Recup(Item, 3) Then
x = x + 1
ReDim Preserve vTabela_Recap(4, x)
vTabela_Recap(0, x) = Tableau_Recup(Item, 1) 'data
vTabela_Recap(1, x) = Tableau_Recup(Item, 2) 'nome sobrenome
vTabela_Recap(2, x) = Tableau_Recup(Item, 3) 'planilha
vTabela_Recap(3, x) = Tableau_Recup(Item, 4) 'Preinscrição

End If
Next

'chamando a subrotina
Ordenar_Dados vTabela_Recap

For Item = 0 To UBound(vTabela_Cabecalho, 1)
.Cells(1, 1) = "Planilha"
.Cells(1, 2) = vNomePlanilha
.Cells(5, 1 + Item) = vTabela_Cabecalho(Item)
Next
vUltimaLinha = .Range("A65536").End(xlUp).Row + 1
.Range("A" & vUltimaLinha).Resize(UBound(vTabela_Recap, 2) + 1, UBound(vTabela_Recap, 1)) = Application.Transpose(vTabela_Recap)

End With
Application.ScreenUpdating = True
x = -1
vNomePlanilha = ""
Erase vTabela_Recap
Next
MsgBox ("Dados filtrados e separados por ordem com sucesso!!"), vbInformation, "Saberexcel - o site das macros"
End Sub


'rotina para ordenar os dados em ordem crescente , é chamada no macro acima : Ordenar_Dados vTabela_Recap
Sub Ordenar_Dados(ByVal T As Variant)
Dim Col As Integer, Col2 As Integer
Dim Tmp1 As Variant, Tmp2 As Variant, Tmp3 As Variant, Tmp4 As Variant
For Col = 0 To UBound(T, 2)
For Col2 = 0 To UBound(T, 2)
If T(0, Col2) > T(0, Col) Then
Tmp1 = T(0, Col): Tmp2 = T(1, Col): Tmp3 = T(2, Col): Tmp4 = T(3, Col)
T(0, Col) = T(0, Col2): T(1, Col) = T(1, Col2): T(2, Col) = T(2, Col2): T(3, Col) = T(3, Col2)
T(0, Col2) = Tmp1: T(1, Col2) = Tmp2: T(2, Col2) = Tmp3: T(3, Col2) = Tmp4
End If
Next
Next
vTabela_Recap = T
End Sub



Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel

Publicidade
Compre com segurança, garantia e ótimos preços

Saberexcel - o site de quem precisa Aprender Macros Microsoft Excel VBA.

Essas códigos(Macros) do Aplicativo Microsoft Excel VBA(Visual Basic Application), filtra determinados dados, e mostra o layout de impressão
dos dados filtrados, observe que fiz vários macros para cada critério, mas isso poderia ser bem mais simples, se voce indicasse um valor de uma célula.

Sub Filtrando_Funcionarios_senhores()
Sheets("Funcionários").Select
Selection.AutoFilter Field:=2, Criteria1:="Senhor"
ActiveWindow.SelectedSheets.PrintPreview
Selection.AutoFilter Field:=2
ActiveWindow.SelectedSheets.PrintPreview
Selection.AutoFilter Field:=2
Sheets("Principal").Select
End Sub

Sub Filtrando_Funcionarios_senhoras()
Sheets("Funcionários").Select
Selection.AutoFilter Field:=2, Criteria1:="Senhora"
ActiveWindow.SelectedSheets.PrintPreview
Selection.AutoFilter Field:=2
ActiveWindow.SelectedSheets.PrintPreview
Selection.AutoFilter Field:=2
Sheets("Principal").Select
End Sub

Sub Filtrando_Funcionarios_senhoritas()
Sheets("Funcionários").Select
Selection.AutoFilter Field:=2, Criteria1:="Senhorita"
ActiveWindow.SelectedSheets.PrintPreview
Selection.AutoFilter Field:=2
ActiveWindow.SelectedSheets.PrintPreview
Selection.AutoFilter Field:=2
Sheets("Principal").Select
End Sub

Sub Filtrando_Jardineiro()
'função do funcionário na empresa.
Dim vFUNCAO As String
Application.ScreenUpdating = False
Sheets("Funcionários").Select
vFUNCAO = InputBox(prompt:="Digite um critério para Funções", _
Title:="Saberexcel - Filtrando Funcionarios", Default:="Jardineiro")
If vFUNCAO = ("") Then Exit Sub 'caso seja anulada a busca na inputbox
Selection.AutoFilter Field:=5, Criteria1:=vFUNCAO
ActiveWindow.SelectedSheets.PrintPreview
Selection.AutoFilter Field:=5
Sheets("Principal").Select
Application.ScreenUpdating = True

End Sub

Sub Filtrando_Motorista()
'função do funcionário na empresa.
Dim vFUNCAO As String
Application.ScreenUpdating = False
Sheets("Funcionários").Select
vFUNCAO = InputBox(prompt:="Digite um critério", _
Title:="Saberexcel - Filtrando Funcionarios", Default:="Motorista")
If vFUNCAO = ("") Then Exit Sub 'caso seja anulada a busca na inputbox
Selection.AutoFilter Field:=5, Criteria1:=vFUNCAO
ActiveWindow.SelectedSheets.PrintPreview
Selection.AutoFilter Field:=5
Sheets("Principal").Select
Application.ScreenUpdating = True

End Sub

Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel




Publicidade
Compre com segurança, garantia e ótimos preços

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

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 - 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,