Alyson Ronnan Martins

Boa tarde @brunoramosd. Preciso que dê uma avaliada no link acima. Verifica se o processo vai funcionar corretamente. https://1drv.ms/x/s!ArTb7UjY-5CriJJlS3bA8PnECEtXSA?e=jU6Svp

Fiz a primeira versão: brunoramosd-0002.xlsm Assim que concluir eu já passo aqui, falta apenas colocar a informação na tabela agrupado.

Segue o link de uma planilha tentando melhorar o desempenho do código. link: https://1drv.ms/x/s!ArTb7UjY-5CriJJjgPv4O28RbcqDrQ?e=P3XBbs Como comentei acima acho que deveria mudar a sequência do seu código para melhorar o desempenho e parar de travar por não conseguir processar. Como não tenho uma base para fazer o teste eu não consigo fazer a avaliação então olha ai e vê como ficou. Abraço.

Um pouco do contexto sim. Nesse caso se o procedimento poderia ser alterado para outra maneira? Exemplo: A tabela "agrupado" recebe todas as linhas da tabela saturno A tabela geral vai "ler" linha por linha na tabela agrupado: :Condicional: CEPINICIAL_BGGERAL > CEPFINAL_BGSATURNO And CEPINIOLD_BGGERAL < CEPINICIAL_BGGERAL And CEPFINAL_BGGERAL < CEPINICIALNEXT_BGSATURNO -->se encontrar ele pode inserir uma linha abaixo da linha agrupado e colocar o valor dentro (valor da tabela geral) -->se não encontrar ele pula para próxima linha da tabela geral Olha se eu consegui explicar a lógica para você.

Não compreendo a regra de negócio do sue código mais não seria melhor percorrer primeiro Geral e depois percorrer o Agrupado na comparação. Processo atual: 1 linha de Agrupado vai percorrer 60 mil linhas de Geral Processo proposto: 1 linha de geral vai verificar 6 mil linha de Saturno Ou a maneira de compreender seu código está explicada de uma maneira muito simples e não entendi. Você testou essa opção? Sub Agrupa_CEPS() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'Para o calculo do excel Dim CEPINICIAL_BGGERAL Dim CEPINIOLD_BGGERAL Dim CEPFINAL_BGGERAL Dim CEPINICIAL_BGSATURNO Dim CEPFINAL_BGSATURNO Dim CEPINICIALNEXT_BGSATURNO 'Copia Cabeçalho padrão Saturno Sheets("Tabela Saturno").Select Range("A1").Select Range(Selection, Selection.End(xlToRight)).Copy Sheets("Tabela Agrupada").Select Range("A1").PasteSpecial Range("A1").Value = "Nome Base" Range("A1").Select Application.CutCopyMode = False 'Inicia varredura dos CEPS pela Saturno Sheets("Base Geral").Select Range("C2").Select Sheets("Tabela Saturno").Select Range("C2").Select Do While ActiveCell <> "" CEPINICIAL_BGSATURNO = ActiveCell.Offset(0, 0).Value CEPINICIALNEXT_BGSATURNO = ActiveCell.Offset(1, 0).Value CEPFINAL_BGSATURNO = ActiveCell.Offset(0, 1).Value ActiveCell.EntireRow.Copy Sheets("Tabela Agrupada").Select ActiveCell.Offset(1, 0).PasteSpecial Application.CutCopyMode = False Do While ActiveCell <> "" Sheets("Base Geral").Select CEPINICIAL_BGGERAL = ActiveCell.Offset(0, 0).Value If ActiveCell.Row = 2 Then CEPINIOLD_BGGERAL = ActiveCell.Offset(0, 0).Value - 1 Else CEPINIOLD_BGGERAL = ActiveCell.Offset(-1, 0).Value End If CEPFINAL_BGGERAL = ActiveCell.Offset(0, 1).Value If CEPINICIAL_BGGERAL > CEPFINAL_BGSATURNO And CEPINIOLD_BGGERAL < CEPINICIAL_BGGERAL And CEPFINAL_BGGERAL < CEPINICIALNEXT_BGSATURNO Then Sheets("Base Geral").Select ActiveCell.EntireRow.Copy Sheets("Tabela Agrupada").Select ActiveCell.Offset(1, 0).PasteSpecial Application.CutCopyMode = False End If Sheets("Base Geral").Select ActiveCell.Offset(1, 0).Select Loop Sheets("Base Geral").Select Range("C2").Select Sheets("Tabela Saturno").Select ActiveCell.Offset(1, 0).Select Loop Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic 'No final do código quando terminar o processo coloca esse para o excel voltar a calular. MsgBox "Finalizado" End Sub

Analisando o seu código vi que tem um while dentro de outro então gerou a duvida. Base Geral Tabela Agrupada Qual das duas planilhas tem mais dados?

Boa tarde @brunoramosd Tenta para o calcula da planilha pare evitar os erros: Application.Calculation = xlCalculationManual 'Para o calculo do excel Application.Calculation = xlCalculationAutomatic 'No final do código quando terminar o processo coloca esse para o excel voltar a calular. O motivo para ele estar "parando" deve ser por conta de várias "seleções" e copias que esta fazendo no processo do código. Tenta mudar o código para não usar o "select" e sim o "cells" que você consegue no usando o loop "FOR".

Perfeito agora aperta F8 até chegar no erro. assim você vai ver a linha que está dando o erro. @rony00001

Bom dia. em que momento ele apresentou o erro? Aperta no depurar e manda um print para saber qual linha apareceu um erro. @rony00001

Fiquei com a duvida sobre o que comentou e coloquei um contador para verificar o "loop" e não encontrei, apesar do site que coloquei se um pouco lento para retornar a informação. Tenho total certeza que fazer isso em Python vai ser muito mais eficiente e rápido. @Diego.Machado

Passei um tempo fazendo alguns testes, encontrei um site que faz a consulta CNPJ (nunca tinha feito) e estou publicando o código do dentro de um arquivo. https://1drv.ms/x/s!ArTb7UjY-5CriJFnFdIQOkp_ODgGhw?e=4t42Zh Segue o código: Sub ConsultarCNPJ() ' Adcionar a referência Microsoft HTML Object Libary Dim IE As Object Dim doc As HTMLDocument Dim CNPJ As Range Dim Status As String ' Cria um novo objeto Internet Explorer Set IE = CreateObject("InternetExplorer.Application") ' Para cada CNPJ na coluna A (de A2 até a última célula preenchida) For Each CNPJ In Worksheets("Planilha1").Range("A2:A" & Worksheets("Planilha1").Cells(Rows.Count, 1).End(xlUp).Row) ' Navega para o site de consulta de CNPJ IE.navigate "https://www.situacao-cadastral.com/" ' Aguarda até que a página seja carregada Do While IE.Busy Or IE.readyState <> 4 Application.Wait DateAdd("s", 1, Now) Loop ' Insere o CNPJ no campo de pesquisa e clica no botão de pesquisa Set doc = IE.document doc.getElementById("doc").Value = CNPJ.Value doc.getElementById("consultar").Click ' Aguarda até que a página com os resultados seja carregada Do While IE.Busy Or IE.readyState <> 4 Application.Wait DateAdd("s", 1, Now) Loop ' Extrai o status do CNPJ e escreve na coluna B Set doc = IE.document Status = doc.getElementsByClassName("vrd")(0).innerText CNPJ.Offset(0, 1).Value = Status Next CNPJ ' Fecha o Internet Explorer IE.Quit End Sub

Option Explicit Public Sub FormatarBordarInferiorCasoDiferenteColunaD() Dim linha As Long Dim UltimaLinha As Long Dim valorCelulaAtual As String Dim valurCelulaSuperior As String UltimaLinha = Cells(Rows.Count, "D").End(xlUp).Row 'Formatar a ultima linha já que a inferior e diferênte FormatarBordarInferiorLinha UltimaLinha 'Percorrer de baixo para cima fazendo a formatação da linha For linha = UltimaLinha To 2 Step -1 valorCelulaAtual = Cells(linha, "D").Value valurCelulaSuperior = Cells(linha - 1, "D").Value If valorCelulaAtual <> valurCelulaSuperior Then FormatarBordarInferiorLinha linha - 1 End If Next linha End Sub Public Sub FormatarBordarInferiorLinha(linha As Long) With Range(Cells(linha, "A"), Cells(linha, "E")) .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).ColorIndex = xlAutomatic .Borders(xlEdgeBottom).TintAndShade = 0 .Borders(xlEdgeBottom).Weight = xlMedium End With End Sub Verificar se ele está funcionando.

Quantas colunas seriam para colocar com a borda inferior em uma espessura maior?

Boa noite @MColucci Eu recomendaria usar formatação condicional em vez de macro. Qual motivo está vendo a necessidade de macro ?(pode ser que eu não esteja vendo o motivo)

Boa noite Diego. Você consegue fazer isso manualmente ? Tem como algum "bloquei" para verificar se a pessoa que esta acessando é um "robô"? Dependendo das suas respostas sim da para fazer. @Diego.Machado

Boa noite. Não lembro de ter esse "bug" de leitura de dados. Pelo resultado das possibilidades eu não que sejam muitos. Eu fazia mais combinações utilizando controle de colaboradores, setores, absenteísmo entre outros. Teria que ter tempo para analisar a seu necessidade e ver como solucionar. Normalmente usamos outras estratégias para melhorar a maneira que o "SQL" recolhe os dados. Já utilizei uma maneira de criar uma "tabela fantasma" para conseguir aumentar em 80% a velocidade de precisão dos dados (só para não deixar tudo na m

Olá @zFuegos, você teria uma planilha com valores fictício para ajuda a entender melhor? Para colocar uma planilha só colocar no onedrive ou gogledrive e compartilhar via link.

@luciano piler

Fiz um teste e aparentemente esta correto. Foi criado código para fazer a leitura do conteudo do excel olhando para a a coluna de quantidade (usando constante, dessa forma você pode adaptar para sua planilha emprecisar procurar no código aonde usar ela). Public Sub DuplicarItemListaEDividirDinheiro() Dim totalLinhasPlanilha As Long Dim linhaAtual As Long Dim quantidadeAtual As Long Dim valorNovo As Double Const ACRESCIMO_LINHAS As Long = 1 Const LINHAS_INICIAL_LOOP As Long = 2 Const QUANTIDADE_MIN_DIVISOR As Long = 1 Const COLUNA_QUANTIDADE As String = "D" Const COLUNA_VALOR As String = "E" 'Captura a ultima linha da planilha totalLinhasPlanilha = fnTotalLinhas For linhaAtual = totalLinhasPlanilha To LINHAS_INICIAL_LOOP Step -ACRESCIMO_LINHAS 'Verificar se a quantida é maior de 1 quantidadeAtual = Cells(linhaAtual, COLUNA_QUANTIDADE).Value If quantidadeAtual > QUANTIDADE_MIN_DIVISOR Then 'Dividir o valor total pela quantidade valorNovo = Cells(linhaAtual, COLUNA_VALOR).Value / quantidadeAtual 'Inserir linha abaixo Rows(linhaAtual + ACRESCIMO_LINHAS & ":" & linhaAtual + quantidadeAtual - ACRESCIMO_LINHAS).Insert Shift:=xlDown 'Inicial um loop 'Caso a linha esteja vazia repete o valor da linha superior 'Coloca o valor da quantidade pelo mínimo definido 'Coloca o valorNovo na coloca valor ReplicarValorLinhaAbaixo linhaAtual, _ quantidadeAtual, _ QUANTIDADE_MIN_DIVISOR, _ valorNovo End If Next linhaAtual End Sub Para fazer o preenchimento da linhas abaixo coloquei ou outro procedimento, só para não ficar tudo misturado: Public Sub ReplicarValorLinhaAbaixo(linhaInicial As Long, quantidadeTotal As Long, quantidadeMinima As Long, novoValor As Double) Dim linhaAtual As Long Dim ultimaLinha As Long Const CORRECAO_LINHA As Long = -1 Const COL_CODIGO As String = "A" Const COL_GUIA As String = "B" Const COL_ITEM As String = "C" Const COL_QTD As String = "D" Const COL_VALOR As String = "E" ultimaLinha = linhaInicial + quantidadeTotal + CORRECAO_LINHA For linhaAtual = linhaInicial To ultimaLinha 'Caso a linha não esteja preenchida pega o texto da linha superior If Cells(linhaAtual, COL_CODIGO).Value = "" Then Cells(linhaAtual, COL_CODIGO).Value = Cells(linhaAtual + CORRECAO_LINHA, COL_CODIGO).Value Cells(linhaAtual, COL_GUIA).Value = Cells(linhaAtual + CORRECAO_LINHA, COL_GUIA).Value Cells(linhaAtual, COL_ITEM).Value = Cells(linhaAtual + CORRECAO_LINHA, COL_ITEM).Value End If 'Atualizar quantidade e valor Cells(linhaAtual, COL_QTD).Value = quantidadeMinima Cells(linhaAtual, COL_VALOR).Value = novoValor Next linhaAtual End Sub E como a planilha pode aumentar de tamanho deixei a ultima linha dinâmica fazendo uma função: Public Function fnTotalLinhas() As Long fnTotalLinhas = Cells(Rows.Count, "A").End(xlUp).Row End Function Segue o link do arquivo excel para download e teste: SepararItemResumo.xlsm Antes de processar: Depois de processar:

Boa tarde, @luciano piler é assim que esta a sua tabela?

Sobe seu documento no google drive ou one drive, com dados fictícios, e coloca aqui. Mais é interessante ter algum código.

Boa tarde @Dorival1000, espero que esteja tudo bem e evoluindo no seu início de aprendizado. Quando você faz o procedimento gravar, tem uma linha fazendo a limpeza dos campos?

Qual o erro @Luiz Fernando Baccarelli?

Boa tarde. Você poderia usar o "SENDKEYS" para enviar comando a tela de salvar. Olhando seu código você os processos direto no código web e depois que aparece você já não vai estar manipulado HTML e sim janela.

Bom dia @Mauricio Coelho Consegue colocar em anexo uma planilha para ver esse erro aqui no computador? (pode ser uma planilha com dados fictícios)