David Ramon

já consegui resolver. Obrigado

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