Caros amigos, acho que já consegui o que pretendia, é claro que pode e deve ser aperfeiçoado, mas consegui o essencial.
Sub org()
Dim Prod(1 To 27) As String
Prod(1) = Sheets("Preçario").Range("B3")
Prod(2) = Sheets("Preçario").Range("B4")
Prod(3) = Sheets("Preçario").Range("B5")
Prod(4) = Sheets("Preçario").Range("B6")
Prod(5) = Sheets("Preçario").Range("B7")
Prod(6) = Sheets("Preçario").Range("B8")
Prod(7) = Sheets("Preçario").Range("B9")
Prod(8) = Sheets("Preçario").Range("B10")
Prod(9) = Sheets("Preçario").Range("B11")
Prod(10) = Sheets("Preçario").Range("B12")
Prod(11) = Sheets("Preçario").Range("B13")
Prod(12) = Sheets("Preçario").Range("B14")
Prod(13) = Sheets("Preçario").Range("B15")
Prod(14) = Sheets("Preçario").Range("B16")
Prod(15) = Sheets("Preçario").Range("B17")
Prod(16) = Sheets("Preçario").Range("B18")
Prod(17) = Sheets("Preçario").Range("B19")
Prod(18) = Sheets("Preçario").Range("B20")
Prod(19) = Sheets("Preçario").Range("B21")
Prod(20) = Sheets("Preçario").Range("B22")
Prod(21) = Sheets("Preçario").Range("B23")
Prod(22) = Sheets("Preçario").Range("B24")
Prod(23) = Sheets("Preçario").Range("B25")
Prod(24) = Sheets("Preçario").Range("B26")
Prod(25) = Sheets("Preçario").Range("B27")
Prod(26) = Sheets("Preçario").Range("B28")
Prod(27) = Sheets("Preçario").Range("B29")
Dim Sect(1 To 3) As String
Sect(1) = "A"
Sect(2) = "B"
Sect(3) = "C"
Dim Pav(1 To 4) As String
Pav(1) = "A"
Pav(2) = "B"
Pav(3) = "C"
Pav(4) = "EXT"
a = 1
b = 1
c = 1
FinalLinhaReg = Sheets("Registos").Range("B" & Rows.Count).End(xlUp).Row 'calcular ultimo registo
Sheets("LISTAS").Select
On Error Resume Next
Cells.SpecialCells(xlCellTypeConstants).Clear
On Error GoTo 0
FinalLinhaList = Sheets("LISTAS").Range("A" & Rows.Count).End(xlUp).Row 'calcular ultima linha da folha LISTAS
Sheets("LISTAS").Range("A" & FinalLinhaList + 3) = "."
Sheets("LISTAS").Range("G" & FinalLinhaList + 3) = "Listagem"
For a = 1 To 3 ' SECTOR
For b = 1 To 4 ' PAV
For c = 1 To 27 ' PROD
For inic = 149 To FinalLinhaReg
If Sheets("Registos").Range("F" & inic) = Pav(b) And Sheets("Registos").Range("H" & inic) = Prod(c) And Sheets("Registos").Range("E" & inic) = Sect(a) Then
FinalLinhaList = Sheets("LISTAS").Range("A" & Rows.Count).End(xlUp).Row
Sheets("LISTAS").Range("A" & FinalLinhaList + 5) = "."
Sheets("LISTAS").Range("B" & FinalLinhaList + 5) = "SECTOR " & Sect(a)
Sheets("LISTAS").Range("A" & FinalLinhaList + 6) = "."
Sheets("LISTAS").Range("C" & FinalLinhaList + 6) = "PAVILHÃO " & Pav(b)
Sheets("LISTAS").Range("A" & FinalLinhaList + 7) = "."
Sheets("LISTAS").Range("D" & FinalLinhaList + 7) = Prod(c)
Sheets("Registos").Range("A148:Q148").Copy Destination:=Sheets("LISTAS").Range("A" & FinalLinhaList + 8)
GoTo verificar
End If
Next inic
verificar:
For inicio = 149 To FinalLinhaReg
If Sheets("Registos").Range("F" & inicio) = Pav(b) And Sheets("Registos").Range("H" & inicio) = Prod(c) And Sheets("Registos").Range("E" & inicio) = Sect(a) Then
Inicsoma = Sheets("LISTAS").Range("K" & Rows.Count).End(xlUp).Row
FinalLinhaList = Sheets("LISTAS").Range("A" & Rows.Count).End(xlUp).Row 'calcular ultima linha da folha LISTAS
SegFinalLinhaList = FinalLinhaList + 1
Sheets("Registos").Range(Sheets("Registos").Cells(inicio, 1), Sheets("Registos").Cells(inicio, 17)).Copy Destination:=Sheets("LISTAS").Range("A" & SegFinalLinhaList) ' & SegFinalLinhaList)
Finalsoma = Sheets("LISTAS").Range("K" & SegFinalLinhaList).End(xlUp).Row
If Inicsoma = Finalsoma Then
cc = Cells(Inicsoma + 1, 11).Value
Sheets("LISTAS").Range("K" & SegFinalLinhaList + 1) = cc
Sheets("LISTAS").Range("K" & SegFinalLinhaList + 1).Select
Selection.NumberFormat = "#,##0.00 $"
SegFinalLinhaList = FinalLinhaList + 1
Else
cc = WorksheetFunction.Sum(Range(Cells(Inicsoma, 11), Cells(Finalsoma, 11)))
Sheets("LISTAS").Range("K" & SegFinalLinhaList + 1) = cc
Sheets("LISTAS").Range("K" & SegFinalLinhaList + 1).Select
Selection.NumberFormat = "#,##0.00 $"
SegFinalLinhaList = FinalLinhaList + 1
End If
End If
Next inicio
Next c
Next b
Next a
End Sub
Postado : 20/09/2017 9:30 am