Option ExplicitPublic plan_lay As String 'planilha layoutPublic plan_dados As String 'planilha para coleta de dadosPublic plan_base As String 'Planilha onde esto as informaes das marcaesPublic prob As String 'ProblemaPublic inic As Long 'Primeira linha das estacasPublic inicio As Long 'variavel para capturar inicio das quebras de linhas das estacasPublic linha_in As Long 'Primeira linha do layoutPublic qtd_prob As Long 'qtd de problemasPublic i0 As Long 'contador dos problemasPublic planejado As Integer 'Informa se esta rodando o planejado qnd 1 ou executado qnd 2'varivel que acumula informaes de erro no preenchimento das estacasPublic erro_est As StringSub start1()'Faz toda a programaoDim de As Long 'Inicio da marcaoDim ate As Long 'Fim da marcaoDim qtd_marc As Integer 'qtd de quadradrinhosDim bloco_de As Long 'Define bloco inicial que a estaca esta marcadaDim linha1 As Long 'Linha em que vai ser preenchida as informaes na planilha de layout no inicioDim bloco_ate As Long 'Define o bloco final que a estaca esta marcadaDim linha2 As Long 'Linha em que vai ser preenchida as informaes na planilha de layout no fimDim result As Integer 'Informa se atualizao vai ser total ou s executadoDim aux_bloco As Integer 'Utilizado para controlar blocos intermadiriosDim i As Long 'Contador que busca problemas na planilha layoutDim i1 As Long 'Contador para pintar e formatar clulasDim i_inicio As Integer: i_inicio = 1 'Contador para definir km de inicioDim coluna_de As Long 'Coluna inicio da marcaoDim coluna_ate As Long 'Coluna fim da marcaoDim ultima_coluna As Long 'Coluna fim da linha ativa'Variveis endereo para planejado e executadoDim i_est_km As String 'Estaca inicial em kmDim i_est_m As String 'Estaca inicial em mDim f_est_km As String 'Estava final em kmDim f_est_m As String 'Estaca finam em mplan_base = "Plan1"plan_dados = "Plan2"plan_lay = "SARACURUNA L1"erro_est = ""'desprotege planilha baseSheets(plan_base).SelectActiveSheet.Unprotect Password:="danielmoraes"'torna plan_lay ativa para iniciar cdigoSheets(plan_lay).SelectFor i_inicio = 1 To 10 If Application.IsNumber(Cells(i_inicio, 1)) = True Then inicio = Cells(i_inicio, 1) End IfNext i_inicio result = CInt(Application.InputBox("Para atualizar tudo, digite 1" & Chr(10) & "Para atualizar executado, digite 2", "Atualizar", , , , , , 1)) Application.ScreenUpdating = FalseApplication.DisplayAlerts = False 'Cancela a operao caso clique cancelar If result = 0 Then Exit Sub End If If result = 1 Then Call listar_problemas Application.statusbar = "Montangem do layout... pode demorar alguns minutos... Aguarde!!" Call montar_layout End If qtd_prob = Application.CountA(Sheets(plan_dados).Range("A:A"))planejado = result10: If planejado = 1 Then i_est_km = "D" i_est_m = "E" f_est_km = "F" f_est_m = "G" Else i_est_km = "I" i_est_m = "J" f_est_km = "K" f_est_m = "L" End Ifinicio = 0aux_bloco = 0inic = Application.Match(inicio, Sheets(plan_lay).Range("A:A"), 0)linha_in = inic + 2i0 = 7Sheets(plan_lay).SelectDo While Sheets(plan_base).Range("C" & i0).Value "" prob = LTrim(RTrim(CStr(Sheets(plan_base).Range("C" & i0).Value))) de = Sheets(plan_base).Range(i_est_km & i0).Value * 1000 + Application.RoundDown(Sheets(plan_base).Range(i_est_m & i0).Value / 50, 0) * 50 ate = Sheets(plan_base).Range(f_est_km & i0).Value * 1000 + Application.RoundUp(Sheets(plan_base).Range(f_est_m & i0).Value / 50, 0) * 50 bloco_de = Application.Match(de, Sheets(plan_lay).Range("A1:A15000"), 1) linha1 = bloco_de + 1 + Application.Match(prob, Sheets(plan_lay).Range("A" & bloco_de + 2 & ":A" & (bloco_de + 2 + qtd_prob - 1)), 0) bloco_ate = Application.Match(ate, Sheets(plan_lay).Range("A1:A15000"), 1) linha2 = bloco_ate + 1 + Application.Match(prob, Sheets(plan_lay).Range("A" & bloco_ate + 2 & ":A" & (bloco_ate + 2 + qtd_prob - 1)), 0) coluna_de = 1 + Application.IfError(Application.Match(de, Sheets(plan_lay).Range(bloco_de & ":" & bloco_de), 0), Application.Match(de, Sheets(plan_lay).Range(bloco_de & ":" & bloco_de)) + 1) coluna_ate = Application.IfError(Application.Match(ate, Sheets(plan_lay).Range(bloco_ate & ":" & bloco_ate), 0), Application.Match(ate, Sheets(plan_lay).Range(bloco_ate & ":" & bloco_ate)) + 1) ultima_coluna = Application.Match(Application.Large(Sheets(plan_lay).Range(bloco_de & ":" & bloco_de), 1), Sheets(plan_lay).Range(bloco_de & ":" & bloco_de)) 'Comenta erros If de + 50 = ate Then coluna_ate = coluna_de ElseIf de > ate Then erro_est = erro_est + "Erro de preenchimento na linha " & i0 & " - " & prob & " - Estaca final antes da inicial" & vbCrLf ElseIf coluna_ate > ultima_coluna Or coluna_de > ultima_coluna Then erro_est = erro_est + "Erro de preenchimento na linha " & i0 & " - " & prob & " - Parte do trecho no existe" & vbCrLf 'coluna_de = coluna_de - 1 coluna_ate = coluna_ate - 1 End If If coluna_de 1 And coluna_ate 1 Then For i = linha1 To (linha2 + qtd_prob - 1) 'Acerta o valor da ltima coluna no bloco corrente If Application.IsNumber(Sheets(plan_lay).Range("A" & i)) = True Then ultima_coluna = Application.Match(Application.Large(Sheets(plan_lay).Range(i & ":" & i), 1), Sheets(plan_lay).Range(i & ":" & i)) End If If Sheets(plan_lay).Range("A" & i) = prob Then 'Comea e terminada no mesmo bloco If bloco_de = bloco_ate Then For i1 = coluna_de To coluna_ate Cells(i, i1).Value = prob 'troquei linha1 por i Cells(i, i1).Select Call formatar_celulas If i1 = coluna_de Then 'adicionar comentrio na clula *****VER COM DANIEL***** End If Next i1 'Bloco inicio ElseIf bloco_de < bloco_ate And aux_bloco = 0 Then aux_bloco = 1 For i1 = coluna_de To ultima_coluna Cells(i, i1).Value = prob Cells(i, i1).Select Call formatar_celulas If i1 = coluna_de Then 'adicionar comentrio na clula *****VER COM DANIEL***** End If Next i1 'Bloco intermedirio ElseIf i < bloco_ate And aux_bloco = 1 Then For i1 = 2 To ultima_coluna Cells(i, i1).Value = prob Cells(i, i1).Select Call formatar_celulas Next i1 'Bloco fim Else For i1 = 2 To coluna_ate Cells(i, i1).Value = prob Cells(i, i1).Select Call formatar_celulas If i1 = coluna_ate Then 'adicionar comentrio na clula *****VER COM DANIEL***** End If Next i1 End If End If Next i End Ifaux_bloco = 0Application.statusbar = "Progresso: " & Format((i0 - 6) / (Application.CountA(Sheets(plan_base).Range("C:C")) - 1), "0.00%") & " Concludo" '****************problema est aqui em algum lugar****************' If planejado = 2 And Sheets(plan_base).Range(i_est_km & i0) "" And Sheets(plan_base).Range(i_est_m & i0) "" Then'' If Sheets(plan_base).Range(f_est_km & i0) "" And Sheets(plan_base).Range(f_est_m & i0) "" Then'' Sheets(plan_base).Select' Sheets(plan_base).Range(i0 & ":" & i0).Select' Selection.Locked = True'' End If' End Ifi0 = i0 + 1Loop If planejado = 1 Then planejado = 2 GoTo 10 End If 'Trava planilha plan_base Sheets(plan_base).Select ActiveSheet.Protect Password:="danielmoraes", DrawingObjects:=True, Contents:=True, Scenarios:=True _ , AllowFormattingCells:=True, AllowFormattingColumns:=True, _ AllowFormattingRows:=True, AllowFiltering:=True, AllowUsingPivotTables:=True''Deleta a plan2 criada pra listar problemas'Sheets(plan_dados).Select'ActiveWindow.SelectedSheets.Delete'Seleciona plan_lay para finalizar cdigo Sheets(plan_lay).SelectApplication.ScreenUpdating = True'Application.DisplayAlerts = TrueApplication.statusbar = False If erro_est "" Then MsgBox (erro_est) End If End SubFunction quad(inicio As Long, fim As Long) As Integer quad = (fim - inicio) / 50End FunctionPrivate Sub listar_problemas()'Lista os problemas, retira os duplicadas e coloca em ordem alfabtica para servir de base a montagem do layout'' On Error GoTo TratarErro Sheets(plan_dados).Select Range("A:A").Select Selection.Delete Sheets(plan_base).Select Range("C7").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets(plan_dados).Select Columns("A:A").Select Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A1").Select 'Selection.ClearContents Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Range("$A$1:$A$1048570").RemoveDuplicates Columns:=1, Header:= _ xlNo ActiveWorkbook.Worksheets(plan_dados).Sort.SortFields.Clear ActiveWorkbook.Worksheets(plan_dados).Sort.SortFields.Add Key:=Range("A1"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets(plan_dados).Sort .SetRange Range("A1:A1048570") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Sheets(plan_lay).SelectExit SubTratarErro:If Err.Number = 9 Then Sheets.Add After:=ActiveSheet ActiveSheet.Name = "Plan2" ResumeEnd IfEnd SubPrivate Sub montar_layout()'monta o layoutSheets(plan_lay).Select5: inic = Application.Match(inicio, Sheets(plan_lay).Range("A:A"), 0) linha_in = inic + 2 i0 = 1 Do While Sheets(plan_dados).Range("A" & i0) "" Sheets(plan_lay).Range(linha_in & ":" & linha_in).Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With If Application.IsNumber(Sheets(plan_lay).Range("B" & linha_in)) = False Then Selection.ClearContents Sheets(plan_lay).Range("A" & linha_in) = Sheets(plan_dados).Range("A" & i0) Else Sheets(plan_lay).Range(linha_in & ":" & linha_in).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Sheets(plan_lay).Range("A" & linha_in) = Sheets(plan_dados).Range("A" & i0) Sheets(plan_lay).Range(linha_in - 1 & ":" & linha_in - 1).Select Selection.Copy Sheets(plan_lay).Range(linha_in & ":" & linha_in).Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End If linha_in = linha_in + 1 i0 = i0 + 1 Loop Do While Sheets(plan_lay).Range("A" & linha_in + 1) "GEOMETRIA" Sheets(plan_lay).Range(linha_in & ":" & linha_in).Select Selection.Delete Loop If Sheets(plan_lay).Range("A" & linha_in + 3) "" Then inicio = Sheets(plan_lay).Range("A" & linha_in + 3) '3 para pegar a primeira marcao das estacas na quebra de linha GoTo 5 End IfEnd SubPrivate Sub formatar_celulas()'Formata de acordo com a varivel planejado, se 1, vermelho. Se planejado igual a 2,branco If planejado = 1 Then 'formata celulas planejadas da maneira que quiser With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Selection.Font.Bold = True Else 'formata celulas exucutadas da maneira que quiser ' If ActiveCell.Value = "" Then'' erro_est = erro_est + "manuteno em trecho no informado como problema anteriormente" & vbCrLf'' End If Selection.ClearContents With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With End If End Sub