Não consegui abrir o link.
Apareceu "Content not found". =/
Segue em anexo o código de qualquer forma.
Super obrigada!
Sub cadastro()
Application.ScreenUpdating = False
Dim myValue As Variant
valor = InputBox("Insira a data. Formato: dd/mm/aaaa")
If StrPtr(valor) = 0 Then
Exit Sub
Else
GoTo Rotulo5
End If
Rotulo5:
i = 6
Do While Cells(i, 2) <> ""
If Cells(i, 5) = "" Then
MsgBox "Preencha o status de todas as atividades!", vbCritical
Cells(i, 5).Select
Exit Sub
End If
i = i + 1
Loop
myValue = CDate(valor)
Sheets("Agenda").Select
lin_fim_d = 6
numd = 0
nok = 0
na = 0
Do While Sheets("Agenda").Cells(lin_fim_d, 3) <> ""
numd = numd + 1
Cells(lin_fim_d, 2).Value = numd
If Cells(lin_fim_d, 5).Value = "nok" Or Cells(lin_fim_d, 5).Value = "Nok" Or Cells(lin_fim_d, 5).Value = "NOK" Then
nok = nok + 1
ElseIf Cells(lin_fim_d, 5).Value = "NA" Or Cells(lin_fim_d, 5).Value = "na" Then
na = na + 1
End If
lin_fim_d = lin_fim_d + 1
Loop
lin_fim_s = 6
nums = numd
Do While Sheets("Agenda").Cells(lin_fim_s, 8) <> ""
nums = nums + 1
Cells(lin_fim_s, 7).Value = nums
If Cells(lin_fim_s, 10).Value = "nok" Or Cells(lin_fim_s, 10).Value = "Nok" Or Cells(lin_fim_s, 10).Value = "NOK" Then
nok = nok + 1
ElseIf Cells(lin_fim_s, 10).Value = "NA" Or Cells(lin_fim_s, 10).Value = "na" Then
na = na + 1
End If
lin_fim_s = lin_fim_s + 1
Loop
lin_fim_m = 6
numm = nums
Do While Sheets("Agenda").Cells(lin_fim_m, 13) <> ""
numm = numm + 1
Cells(lin_fim_m, 12).Value = numm
If Cells(lin_fim_m, 15).Value = "nok" Or Cells(lin_fim_m, 15).Value = "Nok" Or Cells(lin_fim_m, 15).Value = "NOK" Then
nok = nok + 1
ElseIf Cells(lin_fim_m, 15).Value = "NA" Or Cells(lin_fim_m, 15).Value = "na" Then
na = na + 1
End If
lin_fim_m = lin_fim_m + 1
Loop
Sheets("Agenda").Range("B6" & ":" & "B" & lin_fim_d - 1).Copy
Sheets("BD").Range("D7").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Dim LastCol As Integer
'LastCol = Sheets("BD").Cells(7, Columns.Count).End(xlToLeft).Column
LastCol = 3 + numd
Sheets("Agenda").Range("G6" & ":" & "G" & lin_fim_s - 1).Copy
Sheets("BD").Cells(7, LastCol + 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
LastCol = 3 + nums
Sheets("Agenda").Range("L6" & ":" & "L" & lin_fim_m - 1).Copy
Sheets("BD").Cells(7, LastCol + 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
LastCol = 3 + numm
Sheets("BD").Select
Range(Cells(7, 4), Cells(8, LastCol)).Select
With Selection.Interior
.TintAndShade = -4.99893185216834E-02
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
lastrow = Sheets("BD").Cells(Rows.Count, "B").End(xlUp).Row + 1
Cells(lastrow, 2) = myValue
Sheets("Agenda").Range("E6" & ":" & "E" & lin_fim_d - 1).Copy
Sheets("BD").Cells(lastrow, 4).PasteSpecial Paste:=xlPasteValues, Transpose:=True
LastCol = 3 + numd
Sheets("Agenda").Range("J6" & ":" & "J" & lin_fim_s - 1).Copy
Sheets("BD").Cells(lastrow, LastCol + 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
LastCol = 3 + nums
Sheets("Agenda").Range("O6" & ":" & "O" & lin_fim_m - 1).Copy
Sheets("BD").Cells(lastrow, LastCol + 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
LastCol = 3 + numm
produt = (numm - nok - na) / (numm - na)
Sheets("Agenda").Range("D5") = produt
Sheets("BD").Cells(lastrow, 3) = produt
Sheets("BD").Cells(lastrow, 3).Select
Selection.Style = "Percent"
Sheets("BD").Select
For i = 4 To numm + 3
ok = Application.WorksheetFunction.CountIf(Range(Cells(9, i), Cells(lastrow, i)), "ok")
na = Application.WorksheetFunction.CountIf(Range(Cells(9, i), Cells(lastrow, i)), "NA")
tot = Application.WorksheetFunction.CountA(Range(Cells(9, i), Cells(lastrow, i)))
If tot - na = 0 Then
Cells(8, i).Value = 0
Else
produta = ok / (tot - na)
Cells(8, i).Value = produta
Cells(8, i).Select
Selection.Style = "Percent"
End If
Next i
Sheets("BD").Select
Range(Cells(9, 2), Cells(lastrow, numm + 3)).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlHairline
End With
Sheets("BD").Select
Range(Cells(9, 2), Cells(lastrow, 3)).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThick
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlHairline
End With
Sheets("Agenda").ChartObjects("Gráfico 1").Activate
ActiveChart.FullSeriesCollection(1).Values = Range(Sheets("BD").Cells(9, 3), Sheets("BD").Cells(lastrow, 3))
ActiveChart.FullSeriesCollection(1).XValues = Range(Sheets("BD").Cells(9, 2), Sheets("BD").Cells(lastrow, 2))
MsgBox "Agenda cadastrado com sucesso!" & vbCrLf & "Sua performance diária é de:" & vbCrLf & vbCrLf & Round(Sheets("BD").Cells(lastrow, 3).Value * 100) & "%"
Sheets("Agenda").Select
Range("E6:E" & lin_fim_d - 1).ClearContents
Range("J6:J" & lin_fim_s - 1).ClearContents
Range("O6:O" & lin_fim_m - 1).ClearContents
Sheets("BD").Select
Rows(lastrow).Select
End Sub
Postado : 02/03/2015 10:32 am