Alyson Ronnan Martins

Bom dia @Eduardonada O que esta pensando em "encontrar" é o índice para ser excluído ou a senha, ficou meio confuso seu texto.

Já tive problema assim e eu tive que dividir o processo do código, não deixa um único script fazer tudo o que era necessário. Mesmo assim olha se esse código tem o mesmo resultado: Sub AtribuirAtividades() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(5) ' Ajuste o índice se necessário Dim ultimaLinha As Long ultimaLinha = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Dim funcionarios() As String funcionarios = Array("Diogo", "Yanna", "Débora", "Adenilson", "Analista 1", "Analista 2") Dim tiposAtividade As Collection Set tiposAtividade = New Collection Dim i As Long For i = 781 To ultimaLinha If Not IsEmpty(ws.Cells(i, 3).Value) Then Dim tipoAtividade As String tipoAtividade = CStr(ws.Cells(i, 3).Value) On Error Resume Next tiposAtividade.Add tipoAtividade, tipoAtividade On Error GoTo 0 End If Next i Dim mediaAtividadesPorTipo As Double mediaAtividadesPorTipo = Application.WorksheetFunction.RoundUp(tiposAtividade.Count / (UBound(funcionarios) + 1), 0) Dim contadorGeral As Long contadorGeral = 0 Dim tipo As Variant For Each tipo In tiposAtividade Dim contadorPorTipo As Long contadorPorTipo = 0 For Each funcionario In funcionarios For i = 781 To ultimaLinha If ws.Cells(i, 3).Value = tipo And ws.Cells(i, 12).Value = "" Then ws.Cells(i, 12).Value = funcionario contadorGeral = contadorGeral + 1 contadorPorTipo = contadorPorTipo + 1 If contadorPorTipo >= mediaAtividadesPorTipo Then Exit For End If End If Next i If contadorGeral >= ultimaLinha Then Exit For Next funcionario If contadorGeral >= ultimaLinha Then Exit For Next tipo End Sub @Diogo Muscardi

Bom dia @VBA CODE FROM EXCEL TO POW Olha se o código abaixo consegue funcionar no seu processo. Sub PasteExcelDataIntoPowerPointTextbox() Dim ppApp As Object Dim ppSlide As Object Dim ppTextBox As Object Dim xlApp As Excel.Application Dim xlWorkbook As Excel.Workbook Dim xlWorksheet As Excel.Worksheet Dim excelRange As Excel.Range Dim filePath As String ' Initialize PowerPoint and Excel Set ppApp = CreateObject("PowerPoint.Application") ppApp.Visible = True ' Make PowerPoint visible ' Get the PowerPoint file path filePath = Application.GetOpenFilename("PowerPoint Files (*.pptx), *.pptx") If filePath = "False" Then Exit Sub ' User cancelled ' Open the PowerPoint presentation Set ppPresentation = ppApp.Presentations.Open(filePath) ' Assuming the Excel file is already open, else you can open it too Set xlApp = GetObject(, "Excel.Application") Set xlWorkbook = xlApp.ActiveWorkbook Set xlWorksheet = xlWorkbook.Worksheets("HiringResults") ' Change to your sheet name ' Define the ranges and corresponding shape names Dim ranges As Variant Dim shapes As Variant ranges = Array("C1", "C2", "D3", "D4", "D5", "D6", "D7", "D8", "D9", "D10", "D11", "D12", "D13", "D14", "D15", "D16", "D17", "D18", "D19", "D20", "D21") shapes = Array("REFTYPE", "REFBUSINESS", "REFNUMBERFILLS", "REFVARIATION", "REFTTF", "REFCNPS", "REFHMNPS", "REFACTREQ", "REFDIVMALE", "REFDIVFAME", "REFHIREINT", "REFHIREEXT", "REFTSTASO", "REFTSEMRE", "REFTSAGENC", "REFLEVEX", "REFLEVDI", "REFLEVMA", "REFLEVIN", "REFDATAREF", "REFKEYINSIGHTS") ' Loop through the ranges and shapes For i = 0 To UBound(ranges) Set excelRange = xlWorksheet.Range(ranges(i)) Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes(shapes(i)).TextFrame.TextRange excelRange.Copy ppTextBox.Paste Next i ' Clean up Set ppApp = Nothing Set xlApp = Nothing Set xlWorkbook = Nothing Set xlWorksheet = Nothing Set ppPresentation = Nothing MsgBox "Report completed. Please edit and save it." End Sub

Boa tarde. @MColucci. Private Sub txtValorCP_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim zTemp As String txtValorCP.TextAlign = fmTextAlignRight If IsNumeric(Chr(KeyCode)) Or KeyCode = 8 Or (KeyCode >= 96 And KeyCode <= 105) Then If txtValorCP.Text <> "" Then zTemp = txtValorCP.Text & IIf(KeyCode <> 8, Chr(IIf(KeyCode >= 96 And KeyCode <= 105, KeyCode - 48, KeyCode)), "") zTemp = Right(zTemp, Len(zTemp) - 2) zTemp = Replace(zTemp, ".", "") zTemp = Replace(zTemp, ",", "") If KeyCode = 8 Then If Len(zTemp) > 3 Then zTemp = Left(zTemp, Len(zTemp) - 1) Else zTemp = "0" & Left(zTemp, Len(zTemp) - 1) End If End If zTemp = Left(zTemp, Len(zTemp) - 2) & "." & Right(zTemp, 2) Else zTemp = "0.0" & IIf(KeyCode <> 8, Chr(IIf(KeyCode >= 96 And KeyCode <= 105, KeyCode - 48, KeyCode)), "0") End If txtValorCP.Text = Format(Val(zTemp), "R$ ###,##0.00") KeyCode = 0 Else If KeyCode <> 13 And KeyCode <> 9 And KeyCode <> 40 And KeyCode <> 38 Then KeyCode = 0 End If End Sub Seu código foi adaptado coloca uma interpretação dos 'keycode' 96 ao 105 que são os números do teclado numério. olha se funciona no seu código.

@Diego.Machado

É uma pergunta?

Boa tarde. verificar o código abaixo:

Boa tarde. Verifica a resposta no link abaixo:

Boa tarde @Diego.Machado. Fiz uma revisão no código e parou o erro aqui para mim. Faz o teste ai nele: Consultar Status do CNPJ.xlsm Sub ConsultarCNPJ() ' Adicionar a referência Microsoft HTML Object Library Dim IE As Object Dim doc As HTMLDocument Dim CNPJ As Range Dim Status As String Dim countLoop As Long ' Criar 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) countLoop = countLoop + 1 Debug.Print countLoop ' Navegar para o site de consulta de CNPJ IE.navigate "https://www.situacao-cadastral.com/" ' Aguardar até que a página seja carregada Do While IE.Busy Or IE.readyState <> 4 DoEvents Loop ' Inserir o CNPJ no campo de pesquisa e clicar no botão de pesquisa Set doc = IE.document doc.getElementById("doc").Value = CNPJ.Value doc.getElementById("consultar").Click ' Aguardar até que a página com os resultados seja carregada Do While IE.Busy Or IE.readyState <> 4 DoEvents Loop ' Extrair o status do CNPJ e escrever na coluna B Set doc = IE.document Status = doc.getElementsByClassName("vrd")(0).innerText CNPJ.Offset(0, 1).Value = Status Debug.Print "O CNPJ " & CNPJ.Value & " foi consultado." Next CNPJ ' Fechar o Internet Explorer IE.Quit End Sub

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