Option Explicit
Sub pFopag()
Dim lngFill As Long
Dim lngGarb As Long
Dim lngRow As Long
Dim col As Long
Dim lin As Long
Dim rng As Excel.Range
Dim strAddress As String
Dim wksDados As Excel.Worksheet
Dim wksFopag As Excel.Worksheet
Set wksDados = ThisWorkbook.Worksheets("DADOS")
Set wksFopag = ThisWorkbook.Worksheets("FOPAG")
Application.ScreenUpdating = False
Sheets("FOPAG").Visible = True
' Classificar coluna Filial em ordem ascendente
With ActiveWorkbook.Worksheets("DADOS").ListObjects("TAB").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Filtrar valores diferentes de zero na coluna 10
wksDados.ListObjects("TAB").Range.AutoFilter Field:=10, Criteria1:="<>0" _
, Operator:=xlAnd
' Preencher com zeros as células em branco - colunas 6 a 10
lngRow = pGetLastRow(wksDados.Columns("C"))
col = 6
While col < 11
lin = 1
While lin < lngRow
lin = lin + 1
If Cells(lin, col) = "" Then
Cells(lin, col) = "0"
End If
Wend
col = col + 1
Wend
' Preencher o formulário FOPAG (10 quadros)
For lngRow = 2 To pGetLastRow(wksDados.Columns("C"))
If wksDados.Rows(lngRow).Hidden = False Then
Select Case lngFill Mod 10
Case 0: strAddress = "A1"
Case 1: strAddress = "A14"
Case 2: strAddress = "A27"
Case 3: strAddress = "A40"
Case 4: strAddress = "A53"
Case 5: strAddress = "I1"
Case 6: strAddress = "I14"
Case 7: strAddress = "I27"
Case 8: strAddress = "I40"
Case 9: strAddress = "I53"
End Select
Set rng = wksFopag.Range(strAddress)
rng.Range("C2").Value2 = wksDados.Cells(lngRow, "E").Value2
rng.Range("B3").Value2 = wksDados.Cells(lngRow, "B").Value2 _
& " - " & wksDados.Cells(lngRow, "C").Value2
rng.Range("E4").Value2 = wksDados.Cells(lngRow, "F").Value2
rng.Range("E5").Value2 = wksDados.Cells(lngRow, "G").Value2
rng.Range("E6").Value2 = wksDados.Cells(lngRow, "H").Value2
rng.Range("E7").Value2 = wksDados.Cells(lngRow, "I").Value2
rng.Range("E11").Value2 = wksDados.Cells(lngRow, "D").Value2
If lngFill Mod 10 = 9 Then wksFopag.PrintOut
lngFill = lngFill + 1
End If
Next lngRow
' Limpar dados do formulário FOPAG
For lngGarb = (lngFill Mod 10) To 9
Select Case lngGarb Mod 10
Case 0: strAddress = "A1"
Case 1: strAddress = "A14"
Case 2: strAddress = "A27"
Case 3: strAddress = "A40"
Case 4: strAddress = "A53"
Case 5: strAddress = "I1"
Case 6: strAddress = "I14"
Case 7: strAddress = "I27"
Case 8: strAddress = "I40"
Case 9: strAddress = "I53"
End Select
Set rng = wksFopag.Range(strAddress)
rng.Range("C2").Value2 = ""
rng.Range("B3").Value2 = ""
rng.Range("E4").Value2 = ""
rng.Range("E5").Value2 = ""
rng.Range("E6").Value2 = ""
rng.Range("E7").Value2 = ""
rng.Range("E11").Value2 = ""
Next lngGarb
If lngFill Mod 10 <> 0 Then wksFopag.PrintOut
'Ir para o início da planilha DADOS
wksDados.Select
Range("B1").Select
' Todas as linhas da lista filtrada no momento torna visível.Se o AutoFiltro estiver em uso, esse método mudará as setas para "Tudo"
ActiveSheet.ShowAllData
' Classificar coluna NOME em ordem ascendente
Range("C2").Select
With ActiveWorkbook.Worksheets("DADOS").ListObjects("TAB").Sort
.SortFields.Clear
.SortFields.Add Key _
:=Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("FOPAG").Visible = False
Application.ScreenUpdating = True
End Sub
Private Function pGetLastRow(rng As Excel.Range) As Long
'Retorna a linha de uma coluna.
Dim Temp As Long
With rng
On Error Resume Next
Temp = .Find(What:="*" _
, After:=.Cells(1) _
, SearchDirection:=xlPrevious _
, SearchOrder:=xlByRows _
, LookIn:=xlFormulas).Row
If Temp = 0 Then Temp = rng.Cells(1).Row
End With
pGetLastRow = Temp
End Function
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
