sou novo em VBA e ainda estou aprendendo algumas coisa.
procurei em alguns lugares porem não consegui resolver o problema que um das informações apresenta
o codigo abaixo sempre apresenta erro 13 ao indicar o mês 6, basicamente o relatório busca informações e resume em outro arquivo. e para todos os outros meses a info vem correta exceto o mês 6, lembrando que a referencia do mês é colocada por numeros ex: 01 - janeiro e assim por diante.
alguém consegue me da alguma ajuda nisso?
Código:
Option Explicit
Sub Turno()
Dim i As Long, j As Long, k As Long, m As Long, s As Long, t As Byte
Dim EscalaLr As Long, MesaLr As Long, BaseLr As Long
Dim EscalaLc As Long, MesaLc As Long, BaseLc As Long, DadosLc As Byte
Dim TabelaLr As Byte, TabelaLc As Byte
Dim ApontarJorLr As Long
Dim ApontarPreLr As Long
Dim Linha As Long
Dim Mais As Byte
Dim MudarTurno As Byte
Dim MesInput As String
Dim Ano As Byte, Mes As Byte
Dim MesaIni(6) As Byte, MesaFin(6) As Byte
Dim Turnos(3) As String, TurnoNum(3) As Byte
Dim ContarPre(3) As Integer
Dim ContarPreM(6) As Integer, ContarPreT(6) As Integer, ContarPreN(6) As Integer, ContarPreF(6) As Integer
Dim ContarJor(3) As Integer
Dim ContarJorM(6) As Integer, ContarJorT(6) As Integer, ContarJorN(6) As Integer, ContarJorF(6) As Integer
Dim SupIni As Byte, SupFin As Byte
Dim QtTec As Byte, QtSup As Byte
Dim NomeTec() As String, NomeSup() As String
Dim ClmTec() As Byte, ClmSup() As Byte
Dim DataM, DataE As Byte
Dim Dados As Workbook
Dim TabJor As Byte, TabMed As Byte, TabPre As Byte, TabSbr As Byte, TabPtr As Byte, TabPar As Byte, TabEsp As Byte
Ano = 16
MesInput = InputBox("De qual mês deseja rodar o indicador", "Monitoramento de Escala")
Mes = MesInput
Tabela.Cells(1, 2) = Mes
Tabela.Cells(1, 2).Font.Color = vbBlack
Tabela.Cells(1, 2).HorizontalAlignment = xlCenter
For i = 0 To 5
If i <= 3 Then
ContarPre(i) = 0
ContarJor(i) = 0
End If
ApontarJorLr = ApontarJor.Cells(Rows.Count, 1).End(xlUp).Row
ApontarJor.Cells(5, 1).Resize(ApontarJorLr, 10).ClearContents
ApontarPreLr = ApontarPre.Cells(Rows.Count, 1).End(xlUp).Row
ApontarPre.Cells(5, 1).Resize(ApontarPreLr, 10).ClearContents
For j = 2 To TabelaLc
Select Case Tabela.Cells(2, j)
Case Is = "Jornadas >12h"
TabJor = j
Case Is = "Média de Pré"
TabMed = j
Case Is = "Total Pré"
TabPre = j
Case Is = "SBR"
TabSbr = j
Case Is = "PTR"
TabPtr = j
Case Is = "PAR"
TabPar = j
Case Is = "ESP"
TabEsp = j
End Select
Next
For i = 1 To Worksheets.Count
Sheets(i).Visible = True
Sheets(i).AutoFilterMode = False
If Sheets(i).Name = "Base" Then Sheets(i).Cells.Delete
Next i
Turnos(0) = "07:00 X 15:20"
Turnos(1) = "15:00 X 23:20"
Turnos(2) = "23:00 X 07:20"
TurnoNum(0) = 3
TurnoNum(1) = 11
TurnoNum(2) = 19
TurnoNum(3) = 27
EscalaLr = Escala.Cells(Rows.Count, 1).End(xlUp).Row
If Escala.Cells(Rows.Count, 2).End(xlUp).Row <> EscalaLr Then
MsgBox "Há erro no dia da semana ou na data!" & vbCrLf & "Incerrando o processo", 0 + vbCritical, "Aviso"
Exit Sub
End If
EscalaLc = Escala.Cells(1, Columns.Count).End(xlToLeft).Column
If Escala.Cells(2, Columns.Count).End(xlToLeft).Column <> EscalaLc Or Escala.Cells(3, Columns.Count).End(xlToLeft).Column <> EscalaLc Then
MsgBox "Há erro na Mesa ou Turno ou Nome " & vbCrLf & "Incerrando o processo", 0 + vbCritical, "Aviso"
Exit Sub
End If
ReDim NomeTec(QtTec - 1), NomeSup(QtSup - 1) As String
ReDim ClmTec(QtTec - 1), ClmSup(QtSup - 1) As Byte
'i = 0
'For j = 2 To (QtSup + 2)
'If Escala.Cells(1, j) <> "" And Escala.Cells(3, j) <> "" Then
'NomeSup(i) = Escala.Cells(3, j)
'ClmSup(i) = j
'i = i + 1
'End If
'Next j
'i = 0
'For j = ((QtSup + 2) + 2) To EscalaLa
'If Escala.Cells(1, j) <> "" And Escala.Cells(3, j) <> "" Then
'NomeTec(i) = Escala.Cells(3, j)
'ClmTec(i) = j
'i = i + 1
'End If
'Next j
i = 0
For j = 2 To EscalaLc
If Escala.Cells(1, j) <> "" Then
If Escala.Cells(1, j) <> Escala.Cells(1, j - 1) Then
Select Case Escala.Cells(1, j)
Case Is = "Supervisor"
SupIni = j
Case Else
MesaIni(i) = j
End Select
Else
If Escala.Cells(1, j) <> Escala.Cells(1, j + 1) Then
Select Case Escala.Cells(1, j)
Case Is = "Supervisor"
SupFin = j
Case Else
MesaFin(i) = j
i = i + 1
End Select
End If
End If
End If
Next j
Dim ClmDestacamento As Byte, ClmTracao As Byte, ClmInicio As Byte, ClmCargo As Byte, ClmFuncao As Byte
Dim ClmJornadaSegura As Byte, ClmApontamentoPre As Byte, ClmapontamentoJornada As Byte
Dim ClmJor As Long, ClmPre As Long, ClmSbr As Byte, ClmPtr As Byte, ClmPar As Byte, ClmEsp As Byte
Dim ClmGuerra As Byte, ClmMatricula As Byte
Set Dados = Workbooks.Open("W:\CCO\6.Escala\8. Ponto de Maquinista\3. Hajime\10. Base\Dados para apresentação\20" & Ano & "\Dados de Apresentação_" & Mes & ".xlsx")
DadosLc = Dados.Sheets("Base").Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To DadosLc
Select Case Dados.Sheets("Base").Cells(1, j)
Case Is = "Guerra"
ClmGuerra = j
Case Is = "Matrícula"
ClmMatricula = j
Case Is = "Cargo"
ClmCargo = j
Case Is = "Função"
ClmFuncao = j
Case Is = "Destacamento"
ClmDestacamento = j
Case Is = "Início"
ClmInicio = j
Case Is = "Jor.Sg"
ClmJornadaSegura = j
Case Is = "Pré(Pré-Pós_Oficial)"
ClmPre = j
Case Is = "Pré(SBR_Oficial)"
ClmSbr = j
Case Is = "Pré(PTR_Oficial)"
ClmPtr = j
Case Is = "Pré(PAR_Oficial)"
ClmPar = j
Exit For
Case Is = "Pré(ESP_Oficial)"
ClmEsp = j
Case Is = "Pré+6"
ClmApontamentoPre = j
Case Is = "JorSeg+10"
ClmapontamentoJornada = j
End Select
Next j
If Base.Cells(i, ClmJornadaSegura) > 12 Then
Select Case Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
Case 0 To 6
m = Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
If Mes = Month(Base.Cells(i, ClmapontamentoJornada)) Then
If Hour(Base.Cells(i, ClmapontamentoJornada)) >= 6 Or Hour(Base.Cells(i, ClmapontamentoJornada)) = 23 Then
Mais = 3
Linha = Day(Base.Cells(i, ClmapontamentoJornada)) + Mais
Select Case Hour(Base.Cells(i, ClmapontamentoJornada))
Case 7 To 14
t = 0
Case 15 To 22
t = 1
Case Is = 23, 0 To 6
t = 2
End Select
Else
Mais = 2
Linha = Day(Base.Cells(i, ClmapontamentoJornada)) + Mais
t = 2
End If
End If
ApontarJorLr = ApontarJor.Cells(Rows.Count, 1).End(xlUp).Row + 1
For s = SupIni To SupFin
Debug.Print Escala.Cells(Linha, s)
If Escala.Cells(Linha, s) = Turnos(t) Then
If ApontarJor.Cells(ApontarJorLr, 9) = "" Then
ApontarJor.Cells(ApontarJorLr, 9) = Escala.Cells(3, s)
Else
ApontarJor.Cells(ApontarJorLr, 10) = Escala.Cells(3, s)
Exit For
End If
End If
Next s
For k = MesaIni(m) To MesaFin(m)
If Escala.Cells(Linha, k) = Turnos(t) Then
If ApontarJor.Cells(ApontarJorLr, 7) = "" Then
If Escala.Cells(2, k) = "Manhã" Or Escala.Cells(2, k) = "Tarde" Or _
Escala.Cells(2, k) = "Noite" Or Escala.Cells(2, k) = "Folguista" Then
ApontarJor.Cells(ApontarJorLr, 7) = Escala.Cells(3, k)
ApontarJor.Cells(ApontarJorLr, 5) = Escala.Cells(2, k)
If Escala.Cells(2, k) = "Folguista" Then MudarTurno = 3
Else
ApontarJor.Cells(ApontarJorLr, 8) = Escala.Cells(3, k)
End If
Else
If ApontarJor.Cells(ApontarJorLr, 8) = "" Then ApontarJor.Cells(ApontarJorLr, 8) = Escala.Cells(3, k)
Exit For
End If
End If
Next k
Select Case t
Case Is = 0
ContarJorM(m) = ContarJorM(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarJorM(m)
Case Is = 1
ContarJorT(m) = ContarJorT(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarJorT(m)
Case Is = 2
ContarJorN(m) = ContarJorN(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarJorN(m)
Case Is = 3
ContarJorF(m) = ContarJorF(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarJorF(m)
End Select
End Select
End If
If Base.Cells(i, ClmApontamentoPre) > 6 Then
Select Case Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
Case 0 To 6
m = Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
If Mes = Month(Base.Cells(i, ClmApontamentoPre)) Then
If Hour(Base.Cells(i, ClmApontamentoPre)) >= 6 Or Hour(Base.Cells(i, ClmApontamentoPre)) = 23 Then
Mais = 3
Linha = Day(Base.Cells(i, ClmApontamentoPre)) + 3
Select Case Hour(Base.Cells(i, ClmApontamentoPre))
Case 7 To 14
t = 0
Case 15 To 22
t = 1
Case Is = 23, 0 To 6
t = 2
End Select
Else
Mais = 2
Linha = Day(Base.Cells(i, ClmApontamentoPre)) + 2
t = 2
End If
End If
ApontarPreLr = ApontarPre.Cells(Rows.Count, 1).End(xlUp).Row + 1
For s = SupIni To SupFin
If Escala.Cells(Linha, s) = Turnos(t) Then
If ApontarPre.Cells(ApontarPreLr, 9) = "" Then
ApontarPre.Cells(ApontarPreLr, 9) = Escala.Cells(3, s)
Else
ApontarPre.Cells(ApontarPreLr, 10) = Escala.Cells(3, s)
Exit For
End If
End If
Next s
For k = MesaIni(m) To MesaFin(m)
If Escala.Cells(Linha, k) = Turnos(t) Then
If ApontarPre.Cells(ApontarPreLr, 7) = "" Then
If Escala.Cells(2, k) = "Manhã" Or Escala.Cells(2, k) = "Tarde" Or _
Escala.Cells(2, k) = "Noite" Or Escala.Cells(2, k) = "Folguista" Then
ApontarPre.Cells(ApontarPreLr, 7) = Escala.Cells(3, k)
ApontarPre.Cells(ApontarPreLr, 5) = Escala.Cells(2, k)
Else
ApontarPre.Cells(ApontarPreLr, 8) = Escala.Cells(3, k)
End If
Else
If ApontarPre.Cells(ApontarPreLr, 8) = "" Then ApontarPre.Cells(ApontarPreLr, 8) = Escala.Cells(3, k)
Exit For
End If
End If
Next k
If ApontarPre.Cells(ApontarPreLr, 5) = "" Then
MsgBox "ninguém escalado na data " & Linha - Mais & "/" & Mes & " no perído " & Turnos(t)
End If
' Select Case t
' Case Is = 0
' ApontarPre.Cells(ApontarPreLr, 5) = "Manhã"
' Case Is = 1
' ApontarPre.Cells(ApontarPreLr, 5) = "Tarde"
' Case Is = 2
' ApontarPre.Cells(ApontarPreLr, 5) = "Noite"
' End Select
'
'
' Select Case t
' Case Is = 0
' ContarPreM(m) = ContarPreM(m) + 1
' Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarPreM(m)
' Case Is = 1
' ContarPreT(m) = ContarPreT(m) + 1
' Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarPreT(m)
' Case Is = 2
' ContarPreN(m) = ContarPreN(m) + 1
' Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarPreT(m)
' End Select
End Select
End If
Select Case Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
Case 0 To 6
m = Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
If Mes = Month(Base.Cells(i, ClmInicio)) Then
If Hour(Base.Cells(i, ClmInicio)) >= 6 Or Hour(Base.Cells(i, ClmInicio)) = 23 Then
Linha = Day(Base.Cells(i, ClmInicio)) + 3
Select Case Hour(Base.Cells(i, ClmInicio))
Case 7 To 14
t = 0
Case 15 To 22
t = 1
Case Is = 23
t = 2
End Select
Else
Linha = Day(Base.Cells(i, ClmInicio)) + 2
t = 2
End If
End If
For k = MesaIni(m) To MesaFin(m)
If Escala.Cells(Linha, k) = Turnos(t) Then
If Escala.Cells(2, k) = "Folguista" Then MudarTurno = 3
End If
Next
If MudarTurno = 3 Then t = MudarTurno
ContarPre(t) = ContarPre(t) + 1
Select Case t
Case Is = 0
ContarPreM(m) = ContarPreM(m)
Case Is = 1
ContarPreT(m) = ContarPreT(m)
Case Is = 2
ContarPreN(m) = ContarPreN(m)
Case Is = 3
ContarPreF(m) = ContarPreF(m)
End Select
Tabela.Cells(TurnoNum(t) + m + 1, TabPre) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) + Base.Cells(i, ClmPre)
Select Case t
Case Is = 0
ContarPreM(m) = ContarPreM(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabMed) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) / ContarPreM(m)
Case Is = 1
ContarPreT(m) = ContarPreT(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabMed) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) / ContarPreT(m)
Case Is = 2
ContarPreN(m) = ContarPreN(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabMed) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) / ContarPreN(m)
Case Is = 3
ContarPreF(m) = ContarPreF(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabMed) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) / ContarPreF(m)
End Select
Tabela.Cells(TurnoNum(t) + m + 1, TabSbr) = Tabela.Cells(TurnoNum(t) + m + 1, TabSbr) + Base.Cells(i, ClmSbr)
Tabela.Cells(TurnoNum(t) + m + 1, TabPtr) = Tabela.Cells(TurnoNum(t) + m + 1, TabPtr) + Base.Cells(i, ClmPtr)
Tabela.Cells(TurnoNum(t) + m + 1, TabPar) = Tabela.Cells(TurnoNum(t) + m + 1, TabPar) + Base.Cells(i, ClmPar)
Tabela.Cells(TurnoNum(t) + m + 1, TabEsp) = Tabela.Cells(TurnoNum(t) + m + 1, TabEsp) + Base.Cells(i, ClmEsp)
End Select
Debug.Print i
MudarTurno = 0
Next i
For i = 1 To Worksheets.Count
If Sheets(i).Name <> "Escala de Envio" And Sheets(i).Name <> "Tabela" And _
Sheets(i).Name <> "Apontamentos de Jor.Seg >12h" And Sheets(i).Name <> "Apontamentos de Pré >6h" Then Sheets(i).Visible = False
Sheets(i).AutoFilterMode = False
If Sheets(i).Name = "Base" Then Sheets(i).Cells.Delete
Next i
Pergunta
David Ramon
Boa tarde,
sou novo em VBA e ainda estou aprendendo algumas coisa.
procurei em alguns lugares porem não consegui resolver o problema que um das informações apresenta
o codigo abaixo sempre apresenta erro 13 ao indicar o mês 6, basicamente o relatório busca informações e resume em outro arquivo. e para todos os outros meses a info vem correta exceto o mês 6, lembrando que a referencia do mês é colocada por numeros ex: 01 - janeiro e assim por diante.
alguém consegue me da alguma ajuda nisso?
Código:
Option Explicit
Sub Turno()
Dim i As Long, j As Long, k As Long, m As Long, s As Long, t As Byte
Dim EscalaLr As Long, MesaLr As Long, BaseLr As Long
Dim EscalaLc As Long, MesaLc As Long, BaseLc As Long, DadosLc As Byte
Dim TabelaLr As Byte, TabelaLc As Byte
Dim ApontarJorLr As Long
Dim ApontarPreLr As Long
Dim Linha As Long
Dim Mais As Byte
Dim MudarTurno As Byte
Dim MesInput As String
Dim Ano As Byte, Mes As Byte
Dim MesaIni(6) As Byte, MesaFin(6) As Byte
Dim Turnos(3) As String, TurnoNum(3) As Byte
Dim ContarPre(3) As Integer
Dim ContarPreM(6) As Integer, ContarPreT(6) As Integer, ContarPreN(6) As Integer, ContarPreF(6) As Integer
Dim ContarJor(3) As Integer
Dim ContarJorM(6) As Integer, ContarJorT(6) As Integer, ContarJorN(6) As Integer, ContarJorF(6) As Integer
Dim SupIni As Byte, SupFin As Byte
Dim QtTec As Byte, QtSup As Byte
Dim NomeTec() As String, NomeSup() As String
Dim ClmTec() As Byte, ClmSup() As Byte
Dim DataM, DataE As Byte
Dim Dados As Workbook
Dim TabJor As Byte, TabMed As Byte, TabPre As Byte, TabSbr As Byte, TabPtr As Byte, TabPar As Byte, TabEsp As Byte
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ano = 16
MesInput = InputBox("De qual mês deseja rodar o indicador", "Monitoramento de Escala")
Mes = MesInput
Tabela.Cells(1, 2) = Mes
Tabela.Cells(1, 2).Font.Color = vbBlack
Tabela.Cells(1, 2).HorizontalAlignment = xlCenter
For i = 0 To 5
If i <= 3 Then
ContarPre(i) = 0
ContarJor(i) = 0
End If
ContarPreM(i) = 0
ContarPreT(i) = 0
ContarPreN(i) = 0
ContarPreF(i) = 0
ContarJorM(i) = 0
ContarJorT(i) = 0
ContarJorN(i) = 0
ContarJorF(i) = 0
Next
TabelaLc = Tabela.Cells(2, Columns.Count).End(xlToLeft).Column
TabelaLr = Tabela.Cells(Rows.Count, 1).End(xlUp).Row
Tabela.Cells(3, 2).Resize(TabelaLr, TabelaLc).ClearContents
ApontarJorLr = ApontarJor.Cells(Rows.Count, 1).End(xlUp).Row
ApontarJor.Cells(5, 1).Resize(ApontarJorLr, 10).ClearContents
ApontarPreLr = ApontarPre.Cells(Rows.Count, 1).End(xlUp).Row
ApontarPre.Cells(5, 1).Resize(ApontarPreLr, 10).ClearContents
For j = 2 To TabelaLc
Select Case Tabela.Cells(2, j)
Case Is = "Jornadas >12h"
TabJor = j
Case Is = "Média de Pré"
TabMed = j
Case Is = "Total Pré"
TabPre = j
Case Is = "SBR"
TabSbr = j
Case Is = "PTR"
TabPtr = j
Case Is = "PAR"
TabPar = j
Case Is = "ESP"
TabEsp = j
End Select
Next
For i = 1 To Worksheets.Count
Sheets(i).Visible = True
Sheets(i).AutoFilterMode = False
If Sheets(i).Name = "Base" Then Sheets(i).Cells.Delete
Next i
MesaLr = Mesa.Cells(Rows.Count, 1).End(xlUp).Row
MesaLc = Mesa.Cells(1, Columns.Count).End(xlToLeft).Column
Turnos(0) = "07:00 X 15:20"
Turnos(1) = "15:00 X 23:20"
Turnos(2) = "23:00 X 07:20"
TurnoNum(0) = 3
TurnoNum(1) = 11
TurnoNum(2) = 19
TurnoNum(3) = 27
EscalaLr = Escala.Cells(Rows.Count, 1).End(xlUp).Row
If Escala.Cells(Rows.Count, 2).End(xlUp).Row <> EscalaLr Then
MsgBox "Há erro no dia da semana ou na data!" & vbCrLf & "Incerrando o processo", 0 + vbCritical, "Aviso"
Exit Sub
End If
EscalaLc = Escala.Cells(1, Columns.Count).End(xlToLeft).Column
If Escala.Cells(2, Columns.Count).End(xlToLeft).Column <> EscalaLc Or Escala.Cells(3, Columns.Count).End(xlToLeft).Column <> EscalaLc Then
MsgBox "Há erro na Mesa ou Turno ou Nome " & vbCrLf & "Incerrando o processo", 0 + vbCritical, "Aviso"
Exit Sub
End If
QtTec = Application.WorksheetFunction.CountA(Escala.Cells(1, 3).Resize(1, EscalaLc - 2))
QtSup = Application.WorksheetFunction.CountIf(Escala.Cells(1, 3).Resize(1, EscalaLc - 2), "Supervisor")
QtTec = QtTec - QtSup
ReDim NomeTec(QtTec - 1), NomeSup(QtSup - 1) As String
ReDim ClmTec(QtTec - 1), ClmSup(QtSup - 1) As Byte
'i = 0
'For j = 2 To (QtSup + 2)
'If Escala.Cells(1, j) <> "" And Escala.Cells(3, j) <> "" Then
'NomeSup(i) = Escala.Cells(3, j)
'ClmSup(i) = j
'i = i + 1
'End If
'Next j
'i = 0
'For j = ((QtSup + 2) + 2) To EscalaLa
'If Escala.Cells(1, j) <> "" And Escala.Cells(3, j) <> "" Then
'NomeTec(i) = Escala.Cells(3, j)
'ClmTec(i) = j
'i = i + 1
'End If
'Next j
i = 0
For j = 2 To EscalaLc
If Escala.Cells(1, j) <> "" Then
If Escala.Cells(1, j) <> Escala.Cells(1, j - 1) Then
Select Case Escala.Cells(1, j)
Case Is = "Supervisor"
SupIni = j
Case Else
MesaIni(i) = j
End Select
Else
If Escala.Cells(1, j) <> Escala.Cells(1, j + 1) Then
Select Case Escala.Cells(1, j)
Case Is = "Supervisor"
SupFin = j
Case Else
MesaFin(i) = j
i = i + 1
End Select
End If
End If
End If
Next j
Dim ClmDestacamento As Byte, ClmTracao As Byte, ClmInicio As Byte, ClmCargo As Byte, ClmFuncao As Byte
Dim ClmJornadaSegura As Byte, ClmApontamentoPre As Byte, ClmapontamentoJornada As Byte
Dim ClmJor As Long, ClmPre As Long, ClmSbr As Byte, ClmPtr As Byte, ClmPar As Byte, ClmEsp As Byte
Dim ClmGuerra As Byte, ClmMatricula As Byte
Set Dados = Workbooks.Open("W:\CCO\6.Escala\8. Ponto de Maquinista\3. Hajime\10. Base\Dados para apresentação\20" & Ano & "\Dados de Apresentação_" & Mes & ".xlsx")
DadosLc = Dados.Sheets("Base").Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To DadosLc
Select Case Dados.Sheets("Base").Cells(1, j)
Case Is = "Guerra"
ClmGuerra = j
Case Is = "Matrícula"
ClmMatricula = j
Case Is = "Cargo"
ClmCargo = j
Case Is = "Função"
ClmFuncao = j
Case Is = "Destacamento"
ClmDestacamento = j
Case Is = "Início"
ClmInicio = j
Case Is = "Jor.Sg"
ClmJornadaSegura = j
Case Is = "Pré(Pré-Pós_Oficial)"
ClmPre = j
Case Is = "Pré(SBR_Oficial)"
ClmSbr = j
Case Is = "Pré(PTR_Oficial)"
ClmPtr = j
Case Is = "Pré(PAR_Oficial)"
ClmPar = j
Exit For
Case Is = "Pré(ESP_Oficial)"
ClmEsp = j
Case Is = "Pré+6"
ClmApontamentoPre = j
Case Is = "JorSeg+10"
ClmapontamentoJornada = j
End Select
Next j
Dados.Sheets("Base").Cells(1, 1).AutoFilter ClmJornadaSegura, ">0"
Dados.Sheets("Base").Cells(1, 1).AutoFilter ClmPre, ">0"
Dados.Sheets("base").Cells(1, 1).AutoFilter ClmCargo, "MAQ"
Dados.Sheets("base").Cells(1, 1).AutoFilter ClmFuncao, Array("TRE", "FIXA", "HLP", "TSN"), Operator:=xlFilterValues
Dados.Sheets("Base").Cells(1, 1).CurrentRegion.Copy Destination:=Base.Cells(1, 1)
Dados.Close
BaseLr = Base.Cells(Rows.Count, 1).End(xlUp).Row
BaseLc = Base.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To BaseLr
If Base.Cells(i, ClmJornadaSegura) > 12 Then
Select Case Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
Case 0 To 6
m = Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
If Mes = Month(Base.Cells(i, ClmapontamentoJornada)) Then
If Hour(Base.Cells(i, ClmapontamentoJornada)) >= 6 Or Hour(Base.Cells(i, ClmapontamentoJornada)) = 23 Then
Mais = 3
Linha = Day(Base.Cells(i, ClmapontamentoJornada)) + Mais
Select Case Hour(Base.Cells(i, ClmapontamentoJornada))
Case 7 To 14
t = 0
Case 15 To 22
t = 1
Case Is = 23, 0 To 6
t = 2
End Select
Else
Mais = 2
Linha = Day(Base.Cells(i, ClmapontamentoJornada)) + Mais
t = 2
End If
End If
ApontarJorLr = ApontarJor.Cells(Rows.Count, 1).End(xlUp).Row + 1
For s = SupIni To SupFin
Debug.Print Escala.Cells(Linha, s)
If Escala.Cells(Linha, s) = Turnos(t) Then
If ApontarJor.Cells(ApontarJorLr, 9) = "" Then
ApontarJor.Cells(ApontarJorLr, 9) = Escala.Cells(3, s)
Else
ApontarJor.Cells(ApontarJorLr, 10) = Escala.Cells(3, s)
Exit For
End If
End If
Next s
For k = MesaIni(m) To MesaFin(m)
If Escala.Cells(Linha, k) = Turnos(t) Then
If ApontarJor.Cells(ApontarJorLr, 7) = "" Then
If Escala.Cells(2, k) = "Manhã" Or Escala.Cells(2, k) = "Tarde" Or _
Escala.Cells(2, k) = "Noite" Or Escala.Cells(2, k) = "Folguista" Then
ApontarJor.Cells(ApontarJorLr, 7) = Escala.Cells(3, k)
ApontarJor.Cells(ApontarJorLr, 5) = Escala.Cells(2, k)
If Escala.Cells(2, k) = "Folguista" Then MudarTurno = 3
Else
ApontarJor.Cells(ApontarJorLr, 8) = Escala.Cells(3, k)
End If
Else
If ApontarJor.Cells(ApontarJorLr, 8) = "" Then ApontarJor.Cells(ApontarJorLr, 8) = Escala.Cells(3, k)
Exit For
End If
End If
Next k
ApontarJor.Cells(ApontarJorLr, 1) = Base.Cells(i, ClmDestacamento)
ApontarJor.Cells(ApontarJorLr, 2) = Base.Cells(i, ClmGuerra)
ApontarJor.Cells(ApontarJorLr, 3) = Base.Cells(i, ClmMatricula)
ApontarJor.Cells(ApontarJorLr, 4) = Base.Cells(i, ClmapontamentoJornada)
ApontarJor.Cells(ApontarJorLr, 6) = m
If MudarTurno = 3 Then t = MudarTurno
ContarJor(t) = ContarJor(t) + 1
Tabela.Cells(TurnoNum(t), TabJor) = ContarJor(t)
Select Case t
Case Is = 0
ContarJorM(m) = ContarJorM(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarJorM(m)
Case Is = 1
ContarJorT(m) = ContarJorT(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarJorT(m)
Case Is = 2
ContarJorN(m) = ContarJorN(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarJorN(m)
Case Is = 3
ContarJorF(m) = ContarJorF(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarJorF(m)
End Select
End Select
End If
If Base.Cells(i, ClmApontamentoPre) > 6 Then
Select Case Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
Case 0 To 6
m = Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
If Mes = Month(Base.Cells(i, ClmApontamentoPre)) Then
If Hour(Base.Cells(i, ClmApontamentoPre)) >= 6 Or Hour(Base.Cells(i, ClmApontamentoPre)) = 23 Then
Mais = 3
Linha = Day(Base.Cells(i, ClmApontamentoPre)) + 3
Select Case Hour(Base.Cells(i, ClmApontamentoPre))
Case 7 To 14
t = 0
Case 15 To 22
t = 1
Case Is = 23, 0 To 6
t = 2
End Select
Else
Mais = 2
Linha = Day(Base.Cells(i, ClmApontamentoPre)) + 2
t = 2
End If
End If
ApontarPreLr = ApontarPre.Cells(Rows.Count, 1).End(xlUp).Row + 1
For s = SupIni To SupFin
If Escala.Cells(Linha, s) = Turnos(t) Then
If ApontarPre.Cells(ApontarPreLr, 9) = "" Then
ApontarPre.Cells(ApontarPreLr, 9) = Escala.Cells(3, s)
Else
ApontarPre.Cells(ApontarPreLr, 10) = Escala.Cells(3, s)
Exit For
End If
End If
Next s
For k = MesaIni(m) To MesaFin(m)
If Escala.Cells(Linha, k) = Turnos(t) Then
If ApontarPre.Cells(ApontarPreLr, 7) = "" Then
If Escala.Cells(2, k) = "Manhã" Or Escala.Cells(2, k) = "Tarde" Or _
Escala.Cells(2, k) = "Noite" Or Escala.Cells(2, k) = "Folguista" Then
ApontarPre.Cells(ApontarPreLr, 7) = Escala.Cells(3, k)
ApontarPre.Cells(ApontarPreLr, 5) = Escala.Cells(2, k)
Else
ApontarPre.Cells(ApontarPreLr, 8) = Escala.Cells(3, k)
End If
Else
If ApontarPre.Cells(ApontarPreLr, 8) = "" Then ApontarPre.Cells(ApontarPreLr, 8) = Escala.Cells(3, k)
Exit For
End If
End If
Next k
If ApontarPre.Cells(ApontarPreLr, 5) = "" Then
MsgBox "ninguém escalado na data " & Linha - Mais & "/" & Mes & " no perído " & Turnos(t)
End If
ApontarPre.Cells(ApontarPreLr, 1) = Base.Cells(i, ClmDestacamento)
ApontarPre.Cells(ApontarPreLr, 2) = Base.Cells(i, ClmGuerra)
ApontarPre.Cells(ApontarPreLr, 3) = Base.Cells(i, ClmMatricula)
ApontarPre.Cells(ApontarPreLr, 4) = Base.Cells(i, ClmapontamentoJornada)
ApontarPre.Cells(ApontarPreLr, 6) = m
' Select Case t
' Case Is = 0
' ApontarPre.Cells(ApontarPreLr, 5) = "Manhã"
' Case Is = 1
' ApontarPre.Cells(ApontarPreLr, 5) = "Tarde"
' Case Is = 2
' ApontarPre.Cells(ApontarPreLr, 5) = "Noite"
' End Select
'
'
' Select Case t
' Case Is = 0
' ContarPreM(m) = ContarPreM(m) + 1
' Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarPreM(m)
' Case Is = 1
' ContarPreT(m) = ContarPreT(m) + 1
' Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarPreT(m)
' Case Is = 2
' ContarPreN(m) = ContarPreN(m) + 1
' Tabela.Cells(TurnoNum(t) + m + 1, TabJor) = ContarPreT(m)
' End Select
End Select
End If
Select Case Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
Case 0 To 6
m = Application.VLookup(Base.Cells(i, ClmDestacamento), Mesa.Cells(1, 1).Resize(MesaLr, MesaLc), 2, 0)
If Mes = Month(Base.Cells(i, ClmInicio)) Then
If Hour(Base.Cells(i, ClmInicio)) >= 6 Or Hour(Base.Cells(i, ClmInicio)) = 23 Then
Linha = Day(Base.Cells(i, ClmInicio)) + 3
Select Case Hour(Base.Cells(i, ClmInicio))
Case 7 To 14
t = 0
Case 15 To 22
t = 1
Case Is = 23
t = 2
End Select
Else
Linha = Day(Base.Cells(i, ClmInicio)) + 2
t = 2
End If
End If
For k = MesaIni(m) To MesaFin(m)
If Escala.Cells(Linha, k) = Turnos(t) Then
If Escala.Cells(2, k) = "Folguista" Then MudarTurno = 3
End If
Next
If MudarTurno = 3 Then t = MudarTurno
ContarPre(t) = ContarPre(t) + 1
Select Case t
Case Is = 0
ContarPreM(m) = ContarPreM(m)
Case Is = 1
ContarPreT(m) = ContarPreT(m)
Case Is = 2
ContarPreN(m) = ContarPreN(m)
Case Is = 3
ContarPreF(m) = ContarPreF(m)
End Select
Tabela.Cells(TurnoNum(t), TabPre) = Tabela.Cells(TurnoNum(t), TabPre) + Base.Cells(i, ClmPre)
Tabela.Cells(TurnoNum(t), TabMed) = Tabela.Cells(TurnoNum(t), TabPre) / ContarPre(t)
Tabela.Cells(TurnoNum(t), TabSbr) = Tabela.Cells(TurnoNum(t), TabSbr) + Base.Cells(i, ClmSbr)
Tabela.Cells(TurnoNum(t), TabPtr) = Tabela.Cells(TurnoNum(t), TabPtr) + Base.Cells(i, ClmPtr)
Tabela.Cells(TurnoNum(t), TabPar) = Tabela.Cells(TurnoNum(t), TabPar) + Base.Cells(i, ClmPar)
Tabela.Cells(TurnoNum(t), TabEsp) = Tabela.Cells(TurnoNum(t), TabEsp) + Base.Cells(i, ClmEsp)
Tabela.Cells(TurnoNum(t) + m + 1, TabPre) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) + Base.Cells(i, ClmPre)
Select Case t
Case Is = 0
ContarPreM(m) = ContarPreM(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabMed) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) / ContarPreM(m)
Case Is = 1
ContarPreT(m) = ContarPreT(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabMed) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) / ContarPreT(m)
Case Is = 2
ContarPreN(m) = ContarPreN(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabMed) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) / ContarPreN(m)
Case Is = 3
ContarPreF(m) = ContarPreF(m) + 1
Tabela.Cells(TurnoNum(t) + m + 1, TabMed) = Tabela.Cells(TurnoNum(t) + m + 1, TabPre) / ContarPreF(m)
End Select
Tabela.Cells(TurnoNum(t) + m + 1, TabSbr) = Tabela.Cells(TurnoNum(t) + m + 1, TabSbr) + Base.Cells(i, ClmSbr)
Tabela.Cells(TurnoNum(t) + m + 1, TabPtr) = Tabela.Cells(TurnoNum(t) + m + 1, TabPtr) + Base.Cells(i, ClmPtr)
Tabela.Cells(TurnoNum(t) + m + 1, TabPar) = Tabela.Cells(TurnoNum(t) + m + 1, TabPar) + Base.Cells(i, ClmPar)
Tabela.Cells(TurnoNum(t) + m + 1, TabEsp) = Tabela.Cells(TurnoNum(t) + m + 1, TabEsp) + Base.Cells(i, ClmEsp)
End Select
Debug.Print i
MudarTurno = 0
Next i
For i = 1 To Worksheets.Count
If Sheets(i).Name <> "Escala de Envio" And Sheets(i).Name <> "Tabela" And _
Sheets(i).Name <> "Apontamentos de Jor.Seg >12h" And Sheets(i).Name <> "Apontamentos de Pré >6h" Then Sheets(i).Visible = False
Sheets(i).AutoFilterMode = False
If Sheets(i).Name = "Base" Then Sheets(i).Cells.Delete
Next i
End Sub
Link para o comentário
Compartilhar em outros sites
1 resposta a esta questão
Posts Recomendados
Participe da discussão
Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.