Bom, ai vai ...
Dim sheet As String
sheet = ActiveSheet.Name
If FiltraLoja(cbxLoja.Text, sheet) Then
Call ColaVendedor(SelecionaVendedor(), CInt(txLinha.Text), sheet)
Call Relatorio(CInt(txLinha.Text))
Call SomaLinha(CInt(txLinha.Text))
Call SomaTotal(CInt(txLinha.Text))
End If
MsgBox "OLÁ " & Environ("USERNAME") & " SUA PIZZA COM BORDA DE CATUPIRI ESTA PRONTA", vbInformation, "PIZZARIA"
End Sub
Private Sub cbxLoja_Change()
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub Label1_Click()
End Sub
Private Sub UserForm_Activate()
Dim loja As String
Dim i As Integer
Dim f As Integer
f = Sheets("VENDEDOR").Cells(Rows.Count, 10).End(xlUp).Row
For i = 2 To f
loja = Sheets("VENDEDOR").Cells(i, 10)
cbxLoja.AddItem loja
Next i
End Sub
Private Function FiltraLoja(ByVal loja, ByVal sheet) As Boolean
On Error GoTo erro
Sheets("VENDEDOR").Select
ActiveSheet.PivotTables("Tabela dinâmica1").PivotFields("LOCAL").ClearAllFilters
ActiveSheet.PivotTables("Tabela dinâmica1").PivotFields("LOCAL").CurrentPage = loja
Sheets(sheet).Select
FiltraLoja = True
Exit Function
erro:
FiltraLoja = False
End Function
Private Function SelecionaVendedor() As Integer
Dim f As Integer
f = Sheets("VENDEDOR").Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To f
ReDim Preserve Vendedor(f, 5)
Vendedor(i - 4, 0) = Sheets("VENDEDOR").Cells(i, 1)
Vendedor(i - 4, 1) = Sheets("VENDEDOR").Cells(i, 2)
Vendedor(i - 4, 2) = Sheets("VENDEDOR").Cells(i, 3)
Vendedor(i - 4, 3) = Sheets("VENDEDOR").Cells(i, 4)
Vendedor(i - 4, 4) = Sheets("VENDEDOR").Cells(i, 5)
Vendedor(i - 4, 5) = Sheets("VENDEDOR").Cells(i, 6)
Next i
SelecionaVendedor = f
End Function
Private Sub ColaVendedor(ByVal f As Integer, ByVal l As Integer, ByVal sheet)
For i = 0 To f - 4
Sheets(sheet).Cells(l, 2) = Vendedor(i, 0)
Sheets(sheet).Cells(l, 3) = Vendedor(i, 1)
Sheets(sheet).Cells(l, 4) = Vendedor(i, 2)
Sheets(sheet).Cells(l, 5) = Vendedor(i, 3)
Sheets(sheet).Cells(l, 6) = Vendedor(i, 4)
Sheets(sheet).Cells(l, 7) = Vendedor(i, 5)
Call InserirLinha(CStr(l + 1))
l = l + 8
Call CopiaFormatCondicional(l)
Call FormatLinha(CStr(l))
Next i
End Sub
Private Sub InserirLinha(ByVal linha As String)
For Add = 1 To 7
Rows(linha & ":" & linha).Select
Selection.Insert
'Selection.FormatConditions.Delete
Select Case Add
Case 1
Cells(CInt(linha),
= "FAT PROD"
Case 2
Cells(CInt(linha),
= "MRG PROD"
Case 3
Cells(CInt(linha),
= "FAT SERV"
Case 4
Cells(CInt(linha),
= "EFIC SERV"
Case 5
Cells(CInt(linha),
= "FAT TOT"
Case 6
Cells(CInt(linha),
= "MRG TOT"
Case 7
Cells(CInt(linha),
= "PRODUTIV"
End Select
Call FormatLinha1(linha)
linha = CInt(linha) + 1
Next Add
End Sub
Private Sub CopiaFormatCondicional(ByVal l As Integer)
Dim A As String, B As String
A = CStr(l -
B = CStr(l)
Range("C" & A & ":G" & A).Select
Selection.Copy
Range("C" & B).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Private Sub FormatLinha(ByVal l As String)
Range("C" & l & ":AU" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("AW" & l & ":BH" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
Private Sub FormatLinha1(ByVal l As String)
Range("C" & l & ":G" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("M" & l & ":AT" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("AW" & l & ":BG" & l).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
Private Sub Relatorio(ByVal l As Integer)
Dim f As Integer
Dim nome As String
f = Cells(Rows.Count,
.End(xlUp).Row
For i = l To f Step 8
nome = Trim(Cells(i, 3))
If BASE_PDM(nome) Then
For X = 0 To 6
Cells((i + (X + 1)), 15) = REL(X, 0) 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) 'AGO
Cells((i + (X + 1)), 40) = REL(X,
'SET
Cells((i + (X + 1)), 43) = REL(X, 9) 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) 'DEZ
Next X
End If
Next i
End Sub
Private Function BASE_PDM(ByVal nome As String) As Boolean
Dim l As Integer
Dim f As Integer
Dim NomeBase As String
Dim Coluna As Integer
BASE_PDM = False
f = Sheets("BASE").Cells(Rows.Count, 1).End(xlUp).Row
Coluna = 144
For i = 5 To f
NomeBase = Trim(Sheets("BASE").Cells(i, 1))
If nome = NomeBase Then
Call LIMPAR_REL
For y = 0 To 11
REL(0, y) = Sheets("BASE").Cells(i, (Coluna - 6)) 'FAT_PRODUTO
REL(1, y) = Sheets("BASE").Cells(i, (Coluna - 5)) 'MAR_PRODUTO
REL(2, y) = Sheets("BASE").Cells(i, (Coluna - 1)) 'FAT_SERVIÇO
REL(3, y) = Sheets("BASE").Cells(i, (Coluna)) 'EFIC_SERVIÇO
REL(4, y) = REL(0, y) + REL(2, y) 'TOL FAT
REL(5, y) = MEDIA_MARGEM(REL(1, y), REL(3, y)) 'MEDIA SERV
REL(6, y) = Sheets("BASE").Cells(i, (Coluna - 7)) 'PRODUTIVIDADE
Coluna = Coluna - 11
Next y
BASE_PDM = True
Exit Function
End If
Next i
End Function
Private Sub LIMPAR_REL()
For X = 0 To 6
For y = 0 To 11
REL(X, y) = 0
Next y
Next X
End Sub
Private Function MEDIA_MARGEM(ByVal M_PROD As Variant, ByVal M_SERV As Variant)
If M_PROD = "" Or M_SERV = "" Then
MEDIA_MARGEM = M_PROD + M_SERV
Else
MEDIA_MARGEM = (M_PROD + M_SERV) / 2
End If
End Function
Private Sub SomaLinha(ByVal l As Integer)
Dim item As String
Dim f As String
Dim cont As Integer
cont = 0
Call LIMPAR_REL
f = Cells(Rows.Count,
.End(xlUp).Row
For i = l To f Step 8
item = Cells(i, 2)
If item <> "" Then
If i <> l Then
For X = 0 To 6
If X = 1 Or X = 3 Or X = 5 Then
Cells((i + (X + 1)), 15) = REL(X, 0) / cont 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) / cont 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) / cont 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) / cont 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) / cont 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) / cont 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) / cont 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) / cont 'AGO
Cells((i + (X + 1)), 40) = REL(X,
/ cont 'SET
Cells((i + (X + 1)), 43) = REL(X, 9) / cont 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) / cont 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) / cont 'DEZ
Else
Cells((i + (X + 1)), 15) = REL(X, 0) 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) 'AGO
Cells((i + (X + 1)), 40) = REL(X,
'SET
Cells((i + (X + 1)), 43) = REL(X, 9) 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) 'DEZ
End If
Next X
Call LIMPAR_REL
cont = 0
i = i + 8
End If
End If
For X = 0 To 6
REL(X, 0) = REL(X, 0) + Cells((i + (X + 1)), 15) 'JAN
REL(X, 1) = REL(X, 1) + Cells((i + (X + 1)), 18) 'FEV
REL(X, 2) = REL(X, 2) + Cells((i + (X + 1)), 21) 'MAR
REL(X, 3) = REL(X, 3) + Cells((i + (X + 1)), 24) 'ABR
REL(X, 4) = REL(X, 4) + Cells((i + (X + 1)), 27) 'MAI
REL(X, 5) = REL(X, 5) + Cells((i + (X + 1)), 31) 'JUN
REL(X, 6) = REL(X, 6) + Cells((i + (X + 1)), 34) 'JUL
REL(X, 7) = REL(X, 7) + Cells((i + (X + 1)), 37) 'AGO
REL(X,
= REL(X,
+ Cells((i + (X + 1)), 40) 'SET
REL(X, 9) = REL(X, 9) + Cells((i + (X + 1)), 43) 'OUT
REL(X, 10) = REL(X, 10) + Cells((i + (X + 1)), 45) 'NOV
REL(X, 11) = REL(X, 11) + Cells((i + (X + 1)), 47) 'DEZ
Next X
cont = cont + 1
Next i
End Sub
Private Sub SomaTotal(ByVal l As Integer)
Dim item As String
Dim f As String
Dim cont As Integer
cont = 0
Call LIMPAR_REL
f = Cells(Rows.Count,
.End(xlUp).Row
For i = l To f Step 8
item = Cells(i, 2)
If item <> "" Then
If i <> l Then
For X = 0 To 6
REL(X, 0) = REL(X, 0) + Cells((i + (X + 1)), 15) 'JAN
REL(X, 1) = REL(X, 1) + Cells((i + (X + 1)), 18) 'FEV
REL(X, 2) = REL(X, 2) + Cells((i + (X + 1)), 21) 'MAR
REL(X, 3) = REL(X, 3) + Cells((i + (X + 1)), 24) 'ABR
REL(X, 4) = REL(X, 4) + Cells((i + (X + 1)), 27) 'MAI
REL(X, 5) = REL(X, 5) + Cells((i + (X + 1)), 31) 'JUN
REL(X, 6) = REL(X, 6) + Cells((i + (X + 1)), 34) 'JUL
REL(X, 7) = REL(X, 7) + Cells((i + (X + 1)), 37) 'AGO
REL(X,
= REL(X,
+ Cells((i + (X + 1)), 40) 'SET
REL(X, 9) = REL(X, 9) + Cells((i + (X + 1)), 43) 'OUT
REL(X, 10) = REL(X, 10) + Cells((i + (X + 1)), 45) 'NOV
REL(X, 11) = REL(X, 11) + Cells((i + (X + 1)), 47) 'DEZ
Next X
cont = cont + 1
i = i + 8
End If
End If
If (f - 7) = i Then
For X = 0 To 6
If X = 1 Or X = 3 Or X = 5 Then
Cells((i + (X + 1)), 15) = REL(X, 0) / cont 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) / cont 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) / cont 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) / cont 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) / cont 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) / cont 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) / cont 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) / cont 'AGO
Cells((i + (X + 1)), 40) = REL(X,
/ cont 'SET
Cells((i + (X + 1)), 43) = REL(X, 9) / cont 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) / cont 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) / cont 'DEZ
Else
Cells((i + (X + 1)), 15) = REL(X, 0) 'JAN
Cells((i + (X + 1)), 18) = REL(X, 1) 'FEV
Cells((i + (X + 1)), 21) = REL(X, 2) 'MAR
Cells((i + (X + 1)), 24) = REL(X, 3) 'ABR
Cells((i + (X + 1)), 27) = REL(X, 4) 'MAI
Cells((i + (X + 1)), 31) = REL(X, 5) 'JUN
Cells((i + (X + 1)), 34) = REL(X, 6) 'JUL
Cells((i + (X + 1)), 37) = REL(X, 7) 'AGO
Cells((i + (X + 1)), 40) = REL(X,
'SET
Cells((i + (X + 1)), 43) = REL(X, 9) 'OUT
Cells((i + (X + 1)), 45) = REL(X, 10) 'NOV
Cells((i + (X + 1)), 47) = REL(X, 11) 'DEZ
End If
Next X
Exit Sub
End If
Next i
End Sub
-----------------------------
a saida mais facil que eu achei foi inserir a quantidade de linhas que vou usar e na linha que eu escolher .. isso foi facil, só nao estou conseguindo Copiar as ultimas linhas e colar onde eu inseri.