Pesquisar na Comunidade

Boa tarde pessoal, Matheus aqui, iniciante em programação VBA. Tenho uma planilha que já venho fazendo melhorias a algum tempo e preciso da ajuda de vocês... Essa planilha é Relatório Diário de Obras, onde monitoro diariamente os serviços em execução. Inicialmente tenho 2 abas, sendo "Fechamento Mensal" e "01" e os dados são preenchidos a partir da aba "01" que equivale ao primeiro dia do mês. Há um botão de "INSERIR NOVO RDO", que executa a macro "Novo_RDO" que copia a aba ativa, apaga os dados preenchidos equivalentes ao dia e renomeia para "02", porém não estou conseguindo inserir, nessa mesma macro, o comando para excluir as imagens fotográficas para que possam ser inseridas novas imagens referente ao dia "02" sem excluir o objeto de imagem, já que tenho uma outra macro para inserir as novas fotos e cada imagem tem seu botão de inserir. (print anexo) Abaixo a macro que tenho, e nela preciso inserir os códigos para exclusão das imagens Image3 até Image12 da aba "02". Sub Novo_RDO() Sheets(Sheets.Count).Copy After:=Sheets(Sheets.Count) [BP5] = ([BP5] + 1) [CM2] = Format([CM2] + 1, "0#") ActiveSheet.Name = [CM2] Range("AJ19:AK23").ClearContents Range("BP16:BZ19").ClearContents Range("M32:W48").ClearContents Range("AW32:BA61").ClearContents Range("BV32:CA61").ClearContents Range("C64:CA80").ClearContents Range("C2").Activate INSERIR AQUI OS CÓDIGOS PARA EXCLSÃO DAS FOTOS, FICANDO SEM IMAGEM End Sub Poderiam me ajudar? Obrigado

Olá pessoal, Tenho uma pasta com vários arquivos de holerite, que estão renomeados com a matrícula e nome do funcionario. Gostaria de enviar esses contracheques pelo whatsapp, pensei em enviar pelo excel através de VBA, será que é possivel fazer esse envio?

Nesta planilha eu faço o registro dos serviços realizados diariamente. Sendo que estes serviço sofrem alterações: 1 - À realizar: quando planejo um serviço; 2- Realizada: Quando o serviço foi realizado; 3 - Reagendada: Quando planejo a visita porém ela não é feita por algum motivo. Nesse caso preciso reagendar. O reagendamento não exclue o registro original, ele cria um novo registro com o status À Realizar. O registro original muda de à realizar para reagendada. 4- Cancelada: quando ele não é feito de forma alguma se torna cancelada. Todos os registros que insiro na planilha BD são visualizados pela planilha Cro. Porém por lá não consigo editar senão bagunçará as formulas. Então precisei criar um VBA. Eu gostaria de poder EDITAR (mudar status, pesquisar, excluir, inserir um novo serviço, etc) os registros desta planilha por uma tela que já criei porém não consegui programar o VBA sem precisar sair da planilha CRO. Através do botão controle. A planilha Cro é em forma da calendário. Toda informação que é exibida aqui (NA PLANILHA CRO) é puxada da planilha BD. eNTÃO QUALQUER ALTERAÇÃO QUE EU QUEIRA FAZER AQUI TEREI QUE IR NA OUTRA PLANILHA. Através do botão controle é exibida uma janela onde eu gostaria de fazer todos as alterações de que necessito sem a necessidade de ir na planilha BD. Na janela controle gostaria de poder filtrar por data, por cliente, por técnico, por código etc. Gostaria de poder perquisar, excluir, inserir um novo e salva. Ficaria imensamente grato se os amigos pudessem me ajudar . Link do Arquivo: https://docs.google.com/spreadsheets/d/1foKCksbiPFzGPUAazgGc9nrk_dA40k5d/edit?usp=sharing&ouid=108249309679913943005&rtpof=true&sd=true

Olá amigos, estou com um probleminha aqui em um código vba, estou desenvolvendo um controle de biblioteca com menu iniciar, para selecionar as ações de cadastro, devolução, emprestimo etc.., tudo funcionando beleza, o problema é que não estou conseguindo gerar um código para ao clicar no botão fechar (x), esse feche o userform (exemplo: cadastro) que está sendo usado e retorne ao menu iniciar. se alguém tiver alguma dica, agradeço desde já. O código que estu usando temporariamente é esse que segue abaixo, mas o que ele faz é salvar o trabalho que foi feito até o momento e fecha o workbook por completo: Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then 'SALVAR ARQUIVO ThisWorkbook.Save 'SAIR DO EXCEL Application.Quit End If

Boa noite, anexei 2 tabelas de exemplo onde eu gostaria de organizar através de macro as "LOCAÇÕES" da coluna "B" seguindo alguns critérios: * As iniciais "AL...", "DCA...", "DCS...", "SPA...", "RAC..." e "BPOINT" são prefixos ou palavras que não variam - Locações repetidas dentro da mesma célula deverão ser unificadas (ou apagada a duplicata) - Locações que iniciam com "9" seguido de vários números deverão ser apagadas - No final se sobrar "/" deverá ser apagada - Caso estejam presentes, as locações que deverão ser movidas para o final da célula serão essas na respectiva ordem: BPOINT (último) ALQ... (penúltimo) ALT... (antepenúltimo) RAC... (pré-antepenúltimo) SPA... (antes do pré-antepenúltimo) - O restante das locações deverá ser movido para o começo da célula, em ordem alfabética de acordo com a penúltima letra Ex.: Desorganizadas: BPOINT/ALF01F1/ALH02D1/BPOINT/ALQ12A1/ALH02D1/ SPA05B/BPOINT/DCA036C1/DCA036A2/DCA036E1/ALQ12E1/ALT27D3 Organizadas: ALH02D1/ALF01F1/ALQ12A1/BPOINT DCA036A2/DCA036C1/DCA036E1/SPA05B/ALT27D3/ALQ12E1/BPOINT (Eu pintei as letras apenas pra melhor visualização dos critérios aplicados) Agradeço muito desde já quem puder me ajudar nesse desafio. ITEM LOCAÇÃO 10763380 ALT48D1/ALT48D2/DCA001F1/DCA001E1/ALT48D3/DCA001E3/DCA001F3/ 15396678 ALT19A3/DCS018E1/DCS018D1/DCS018C1/DCS018E2/ALT62G1 15432208 SPA15A/ALQ08A2/DCS028B1/DCS028B2/ALT41A3 15432210 DCA028E1/ALT43G1/ALT42D1/ALT42A1/ALT37G3 15396704 93300001/BPOINT/ALT44A3/DCA034B1/SPA03A/DCA034A1/BPOINT/DCA034A2 10763376 SPA05B/BPOINT/DCA036C1/DCA036A2/DCA036E1/ALQ12E1/ALT27D3 ITEM LOCAÇÃO 10788155 ALD21A2/BPOINT/RAC2SVC1 12092080 ALQ01B2/BPOINT/ALE01F4/ 12065932 BPOINT/ALF01F1/ALH02D1/BPOINT/ALQ12A1/ALH02D1/ PPN00698 90056896/SPA01A/ALF01A2 15344639 RAC2SVC1/ALF01J1/ALB08E3 10810293 SPA01B/ALF03A2/ 10863947 ALG04C4/ALG04C4/ 12198556 90057421/ALL01J4/SPA08B/ 15470987 AST29D1/ALQ12A1/SPA04B

Olá, pessoal, bom dia, tudo bem? Poderiam me ajudar a melhorar o código abaixo? Fiz sozinho, sem conhecimento prévio, e ele funciona as vezes....rs - as vezes da erro. Coisas que eu queria melhorar: Dar opção ao usuário escolher a origem do arquivo, ao invés de ele ser obrigado a deixar o arquivo salvo no C:\Users\Public\filename.pptx. Outra coisa, meu código é tão amador que ele copia e cola 1900x o mesmo item, mas de celulas diferentes. Quando as informações chegam no Powerpoint, elas estão sendo coladas nos campos corretos, da maneira correta. Alguém pode me ajudar, por favor? 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 ' Initialize PowerPoint and Excel Set ppApp = CreateObject("PowerPoint.Application") ppApp.Visible = True ' Make PowerPoint visible ' Open the PowerPoint presentation Set ppPresentation = ppApp.Presentations.Open("C:\Users\Public\filename.pptx") ' 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 ' Get the range of Excel data you want to copy Set excelRange = xlWorksheet.Range("C1") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFTYPE").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("C2") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFBUSINESS").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D3") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFNUMBERFILLS").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D4") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFVARIATION").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D5") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFTTF").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D6") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFCNPS").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D7") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFHMNPS").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D8") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFACTREQ").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D9") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFDIVMALE").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D10") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFDIVFAME").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D11") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFHIREINT").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D12") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFHIREEXT").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D13") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFTSTASO").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D14") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFTSEMRE").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D15") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFTSAGENC").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D16") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFLEVEX").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D17") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFLEVDI").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D18") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFLEVMA").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D19") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFLEVIN").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D20") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFDATAREF").TextFrame.TextRange excelRange.Copy ppTextBox.Paste Set excelRange = xlWorksheet.Range("D21") Set ppSlide = ppPresentation.Slides(1) Set ppTextBox = ppSlide.Shapes("REFKEYINSIGHTS").TextFrame.TextRange excelRange.Copy ppTextBox.Paste ' 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

Estou com um problema quando vou tentar executar meu código pelo F5 ele trava, porém quando eu rodo no F8 ele funciona. O meu código ele é para fazer o seguinte: Tabela 1: lista de CEPS tenho 1 inicial e 1 final 2 colunas (5.800 LINHAS) Tabela 2: Outra tabela com mais CEPS 1 inicial e 1 final 2 colunas (33.204 LINHAS) A ideia é identificar os CEPS faltantes na tabela 2 e montar uma nova tabela 3 com essas duas tabelas. Fiz o código abaixo: --------------------------------------------------------- Sub Agrupa_CEPS() Application.ScreenUpdating = False 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 MsgBox "Finalizado" End Sub --------------------------------------------------- Poderiam me ajudar por gentileza? Obrigado

Olá Vocês podem me ajudar nessa questão. Como faço para deletar um registro em um recordset em um banco de dados XLSX. O comando recordset.delete não funciona.

Olá pessoal, tudo bem? Estou criando uma planilha para a empresa e queria gerar um relatório simples, porém bonito, usando o UseForm, mas estou iniciando no VBA e já tem um tempo que não mexo com programação. Alguém poderia me ajudar? A dúvida é o seguinte: Irei escolher uma opção de Produto e uma opção de Embalagem. Nisso clico em gerar e gera o texto com a somatória de todas as saídas desse produto. No Excel fiz isso usando o PROCV, mas não sei aplicar no VBA. Irei mandar uma imagem do UseForm e um rascunho do possível código. Já peço desculpas pelos erros de lógica no algoritmo, estou enferrujado. Desde já agradeço com a ajuda.

Bom dia! Por favor, me ajudem. Já tentei de tudo e fiz diversas pesquisas sem solução. Tenho um código vba todo pronto. Porém, o único problema, é que o arquivo original é em formato csv/txt. Quando abro o arquivo clicando normalmente, ele não inverte as datas na coluna F por exemplo. Porém, ao utilizar o codigo VBA ele inverte logo ao realizar o comando para abrir o arquivo, impossibilitando de aplicar soluções como vba.format, format, cdate, etc.... Impossibilita porque ele altera a data só até o dia 12 de cada mês, porque não existe mês 13..Então é como se ficassem 2 formatos no arquivos, um brasileiro e 1 americano. Ou seja, ele já abre o arquivo lendo o mês errado. PlanilhaModelo ArquivoRodarNaPlanilha Segue código e arquivos modelo para testes em anexo. Muito obrigado. Public CaminhoArquivo, NomeDoArquivo, NomeDoArquivoComExtensao, Aba As Variant 'Public: Declaração de variável global, ou seja, disponível para qualquer rotina deste projeto. Option Explicit Sub AtualizarmovT99Nv() Call OpenFileDialog End Sub Public Function OpenFileDialog() As String Application.ScreenUpdating = False Application.DisplayAlerts = False ActiveSheet.DisplayPageBreaks = False 'Desabilita as quebras de páginas Dim Filter As String, Title As String Dim FilterIndex As Integer Dim Filename As Variant Dim Aba As Variant ' Define o filtro de procura dos arquivos Filter = "Arquivos Excel (*.xls*),*.xl*," ' O filtro padrão é *.* FilterIndex = 4 ' Define o Título (Caption) da Tela Title = "Selecione o arquivo correspondente ao Cadastro de Produtos" ' Define o disco de procura ChDrive ("C") ChDir ("C:\Users") With Application ' Abre a caixa de diálogo para seleção do arquivo com os parâmetros Filename = .GetOpenFilename(Filter, FilterIndex, Title) ' Reseta o Path ChDrive (Left(.DefaultFilePath, 1)) ChDir (.DefaultFilePath) End With ' Abandona ao Cancelar If Filename = False Then MsgBox "Nenhum arquivo foi selecionado." Exit Function End If ' Retorna o caminho do arquivo OpenFileDialog = Filename CaminhoArquivo = Filename Dim Pergunta As VbMsgBoxResult Pergunta = MsgBox("Deseja realmente abrir o arquivo " & CaminhoArquivo & "?", vbYesNo + vbQuestion, "Abrir Arquivo") If Pergunta = vbYes Then 'Apagar a primeira linha para subscrever nova ramificação de pasta Sheets("CaminhoArquivo").Visible = True Sheets("CaminhoArquivo").Select Rows("1:1").Select Selection.Delete Shift:=xlUp 'Transcreve o endereço do arquivo para a celula a1 Sheets("CaminhoArquivo").Range("A1").Value = CaminhoArquivo Sheets("CaminhoArquivo").Range("A1").Select 'Clica na celula do A1 'Procedimento texto para colunas Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _ TrailingMinusNumbers:=True 'Procedimento para retornar somente o nome do arquivo 'A função replace equivale a substituir NomeDoArquivo = VBA.Replace(VBA.Replace(Sheets("CaminhoArquivo").Cells(1, Application.CountA(Sheets("CaminhoArquivo").Range("1:1"))).Value, ".xls", ""), ".xlsx", "") Sheets("CaminhoArquivo").Activate ActiveWindow.SelectedSheets.Visible = False Sheets("movT99").Activate Else MsgBox "Proceder nova abertura", vbCritical, "Abrir arquivo" End If Call FormatarCadastro 'Call Atualizar MsgBox ("movT99 atualizada com sucesso!") Application.ScreenUpdating = True Application.DisplayAlerts = True End Function Sub FormatarCadastro() Dim NomeDesseArquivo, TotalLinhasCustInv, DataHora, Linhas, _ TotalLinhasmovT99, TotalLinhasFormulas, Aba, TotalLinhas As Variant Dim CaixaTexto As String 'Capta o nome deste projeto, ou seja, 02 fevereiro.xlsm NomeDesseArquivo = ActiveWorkbook.Name 'Limpar área movT99 analítico Windows(NomeDesseArquivo).Activate 'Procedimento para abrir pasta de trabalho Workbooks.Open Filename:=CaminhoArquivo NomeDoArquivoComExtensao = ActiveWorkbook.Name Aba = ActiveSheet.Name TotalLinhas = Sheets(Aba).Range("A" & Rows.Count).End(xlUp).Row Sheets(Aba).Activate '-------------------------------------------------------------------------------------------------------------- 'Formatar arquivo para copiar Range("A:A,E:E,H:H,J:J,K:K,L:L,M:M,N:N,P:P,Q:Q,U:X").Delete Shift:=xlToLeft '-------------------------------------------------------------------------------------------------------------- TotalLinhas = Sheets(Aba).Range("A" & Rows.Count).End(xlUp).Row Range("A2:J" & TotalLinhas).Copy Windows(NomeDesseArquivo).Activate Sheets("movT99").Activate TotalLinhasmovT99 = Sheets("movT99").Range("N" & Rows.Count).End(xlUp).Row TotalLinhasFormulas = Sheets("movT99").Range("K" & Rows.Count).End(xlUp).Row Range("N" & TotalLinhasmovT99 + 1).PasteSpecial 'DoEvents 'Aguardar o processamento anterior para processar a px linha Windows(NomeDoArquivoComExtensao).Activate ActiveWindow.Close savechanges:=False TotalLinhasmovT99 = Sheets("movT99").Range("N" & Rows.Count).End(xlUp).Row 'Range(Cells(TotalLinhasFormulas + 1, 1), Cells(TotalLinhasmovT99, 1)).Value = CaixaTexto 'Range(Cells(TotalLinhasFormulas + 1, 1), Cells(TotalLinhasmovT99, 1)) = VBA.Format(CaixaTexto, "mm/dd/yyyy") 'Application.Calculation = xlCalculationManual ' Range(Cells(TotalLinhasFormulas + 1, 9), Cells(TotalLinhasmovT99, 9)).Value = "=IF(AND(ISNA(IF(OR(RC[-6]=11,RC[-6]=0),0,VLOOKUP(movT99!RC[-6],Tabela1[[#All],[ITEM]:[CUSTO_INV]],7,0)*movT99!RC[-4])),RC[-6]<>11,RC[-6]<>0),""Atualizar movT99 custo"",IF(OR(RC[-6]=11,RC[-6]=0),0,VLOOKUP(movT99!RC[-6],Tabela1[[#All],[ITEM]:[CUSTO_INV]],7,0)*movT99!RC[-4]))" ' Range(Cells(TotalLinhasFormulas + 1, 10), Cells(TotalLinhasmovT99, 10)).Value = "=IF(AND(ISNA(IF(OR(RC[-7]=11,RC[-7]=0),0,INDEX(Tabela1[[#All],[LINHA RESUMIDA]],MATCH(RC[-7],Tabela1[[#All],[ITEM]],0)))),RC[-7]<>11,RC[-7]<>0),""Atualizar movT99 Linha Resumida"",IF(OR(RC[-7]=11,RC[-7]=0),"""",INDEX(Tabela1[[#All],[LINHA RESUMIDA]],MATCH(RC[-7],Tabela1[[#All],[ITEM]],0))))" ' Range(Cells(TotalLinhasFormulas + 1, 11), Cells(TotalLinhasmovT99, 11)).Value = "=IFERROR(IFERROR(VLOOKUP(RC[-9],Tabela2[#All],2,0),VLOOKUP(RC[-4],Tabela2[#All],2,0)),RC[-4])" 'Range("I" & TotalLinhasFormulas + 1).Value = "=IF(AND(ISNA(IF(OR(RC[-6]=11,RC[-6]=0),0,VLOOKUP(movT99!RC[-6],Tabela1[[#All],[ITEM]:[CUSTO_INV]],7,0)*movT99!RC[-4])),RC[-6]<>11,RC[-6]<>0),""Atualizar movT99 custo"",IF(OR(RC[-6]=11,RC[-6]=0),0,VLOOKUP(movT99!RC[-6],Tabela1[[#All],[ITEM]:[CUSTO_INV]],7,0)*movT99!RC[-4]))" 'Range("J" & TotalLinhasFormulas + 1).Value = "=IF(AND(ISNA(IF(OR(RC[-7]=11,RC[-7]=0),0,INDEX(Tabela1[[#All],[LINHA RESUMIDA]],MATCH(RC[-7],Tabela1[[#All],[ITEM]],0)))),RC[-7]<>11,RC[-7]<>0),""Atualizar movT99 Linha Resumida"",IF(OR(RC[-7]=11,RC[-7]=0),"""",INDEX(Tabela1[[#All],[LINHA RESUMIDA]],MATCH(RC[-7],Tabela1[[#All],[ITEM]],0))))" 'Range("K" & TotalLinhasFormulas + 1).Value = "=IFERROR(IFERROR(VLOOKUP(RC[-9],Tabela2[#All],2,0),VLOOKUP(RC[-4],Tabela2[#All],2,0)),RC[-4])" Range("K" & TotalLinhasFormulas + 1).Value = "=HOUR(RC[6])" Range("L" & TotalLinhasFormulas + 1).Value = "=INT(RC[5])" Range("M" & TotalLinhasFormulas + 1).Value = "=RC[1]&RC[2]&RC[9]" Range(Cells(TotalLinhasFormulas + 1, 11), Cells(TotalLinhasFormulas + 1, 13)).Copy Destination:=Range(Cells(TotalLinhasFormulas + 2, 11), Cells(TotalLinhasmovT99, 13)) Calculate 'Application.Calculation = xlCalculationAutomatic Range(Cells(TotalLinhasFormulas, 11), Cells(TotalLinhasmovT99, 13)).Value = Range(Cells(TotalLinhasFormulas, 11), Cells(TotalLinhasmovT99, 13)).Value End Sub

Olá, pessoal queria saber qual comando posso usar para obter o caminho do arquivo coreldraw que esta ativo no momento que executo a macro.Tente usar o comando "ThisWorkbook.Path" mas ele não funciona.

olá pessoal, sei um pouco de VBA e queria fazer uma macro que quando executada dentro de manual ele pegue uma imagem que esta na mesma pasta do arquivo CorelDraw, posicione no espaço e dimensione já com as medidas, depois disso ele apague a imagem existente e coloque a nova imagem na mesmo posição da imagem antiga dentro da camada. Estou usando o comando ActiveWorkbook.Path para pegar o caminho na rede onde esta o arquivo CorelDraw mas parece que ele não reconhece e esta dando o segui erro: Objeto requerido (Erro 424). Poderia me ajudar? OBS: código ainda não esta completo! Código: Sub trocar_imagens() ' Recorded 03/03/2023 Dim impopt As StructImportOptions Set impopt = CreateStructImportOptions With impopt .Mode = cdrImportFull .MaintainLayers = True With .ColorConversionOptions .SourceColorProfileList = "sRGB IEC61966-2.1,U.S. Web Coated (SWOP) v2,Dot Gain 20%" .TargetColorProfileList = "sRGB IEC61966-2.1,U.S. Web Coated (SWOP) v2,Dot Gain 20%" End With End With 'Dim pasta As ImportFilter 'Set pasta = ActiveWorkbook.Path & "\" & "\IMAGENS\FIG. A1.JPG" 'pasta.Finish 'pasta = A 'MsgBox pasta Dim impflt As ImportFilter Set impflt = ActiveDocument.Pages(24).Layers("Camada 1").ImportEx(ActiveWorkbook.Path & "\IMAGENS\FIG. A1.JPG", cdrJPEG, impopt) impflt.Finish Dim s1 As Shape Set s1 = ActiveShape ActiveDocument.Pages(24).Layers("Camada 1").Shapes(1).Move -0.198937, -0.752177 ActiveDocument.ReferencePoint = cdrCenter ActiveDocument.Pages(24).Layers("Camada 1").Shapes(1).SetSize 6.889764, 4.774157 ActiveDocument.Pages(24).Layers("Camada 1").Shapes(1).SetPosition 4.133858, 5.11811 ActiveDocument.Pages(24).Layers("Camada 1").Shapes(3).Delete ActiveDocument.Pages(24).Layers("Camada 1").Shapes(2).OrderBackOf ActiveDocument.Pages(24).Layers("Camada 1").Shapes(1) ActiveDocument.Pages(25).Activate End Sub

Boa tarde a todos, Gostaria de ajuda em relação a nova politica que incluíram na empresa. Selecionar confidencialidade do arquivo. Isso atrapalhou todas as macros que tenho, e não tem como tirar isso, é obrigatório. Como seria o código para selecionar a confidencialidade como publica, salvar e fechar o arquivo ? essa confidencialidade que estou comentando... Obrigado a todos ! e uma ótima semana !

Olá, pessoal! Como tenho pouca experiência em VBA, estou com dificuldade em desenvolver um código para atender minha necessidade. Garimpando na internet encontrei alguns códigos prontos que ajudaram em partes, mas não toda minha necessidade. Tenho uma planilha do excel com duas colunas: coluna A: exame da Semana - novembro - 07-11-2022.pdf coluna B: https://drive.google.com/uc?export=download&id=1 Gostaria de salvar esse pdf do hiperlink com o nome de acordo com a coluna A no endereço C:\teste\ Encontrei este código, mas ele vai direto para meus downloads, ignorando as etapas de: alteração do nome do arquivo e também ignorando pasta que eu quero salvá-lo: Sub OpenHyperLinks() 'Update 20141124 Dim xHyperlink As Hyperlink Dim WorkRng As Range On Error Resume Next xTitleId = "KutoolsforExcel" Set WorkRng = Application.Selection Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8) For Each xHyperlink In WorkRng.Hyperlinks xHyperlink.Follow Next End Sub _________________________________________________________________________________________________________________________ Esse outro código que encontrei, o resultado foi o que eu queria, porém os arquivos abrem como corrompidos: Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _ ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long Sub FazDownloadArquivos() 'macro que faz o download de arquivos a partir da URL da PLANILHA DADOS Dim NomeDiretorio As String Dim SiteArquivo, NomeSalvar As String Dim Resultado, i As Integer NomeDiretorio = "\\Documents\teste MACRO exame\" If Dir(NomeDiretorio, vbDirectory) = "" Then MsgBox "Deu ruim, o diretório não existe!" Else For i = 2 To 6 SiteArquivo = Worksheets("Recebimento_Exames").Cells(i, 2) NomeSalvar = NomeDiretorio & Worksheets("Recebimento_Exames").Cells(i, 1).Value & ".pdf" Resultado = URLDownloadToFile(0, SiteArquivo, NomeSalvar, 0, 0) If Resultado <> 0 Then MsgBox "Não consegui achar o arquivo " & SiteArquivo End If Next i End If End Sub ALGUÉM DA COMUNIDADE PODE ME AJUDAR? Obrigada!!!

Boa tarde, tenho o seguinte código que percorre a planilha Porém o texto que está na célula I3 contém mais de 256 caracteres e por isso aparece o seguinte erro Como eu devo fazer para que seja possível inserir um texto com mais de 256 caracteres substituindo a tag #acao123coletiva123guedes

Olá Pessoal ! Vejam se conseguem me ajudar... Fiz uma planilha geradora de etiquetas e fiz uma macro simples de impressão das etiquetas numa determinada impressora, e está funcionando ! Porém, são muitas etiquetas para impressão e para que eu não tivesse que ficar digitando uma por uma para imprimir, eu queria ver a possibilidade de uma impressão em série, onde eu colocaria o intervalo de etiquetas puxando do banco de dados e a impressora imprimisse uma seguida da outra.. Agradeço desde já !

Trabalho com planilhas para cálculos de comissão de funcionários. Possuo uma planilha com as seguintes caracteristicas: E uma coluna possuo valores de produções dos funcionários, como no exemplo: COLUNA A 4 570 621 314 476 240 120 Preciso que na célula seguinte ele faça multiplicação seguindo os seguintes critérios: Por 1,3 se o valor for menor que 100. Por 1,4 se o valor está entre 101 e 200. Por 1,5 se o valor está entre 201 e 300. Por 1,6 se o valor está entre 301 e 400. Por 1,7 se o valor está entre 401 e 500. Por 1,8 se o valor está entre 501 e 600. Por 1,9 se o valor está entre 601 e 700. Por 2,0 se o valor está entre 701 e 800. Por 2,1 se o valor está entre 801 e 900. Por 2,5 se o valor está entre 901 e 1000. Por 3,0 se o valor for maior que 1001. Procurei por fórmulas com essa função, porém, não encontrei nenhuma que atendesse as minhas necessidades. Minha dúvida é: Há alguma função no excel que tenha essas caracteristicas ou terei que usar VBA? Se terei que usar VBA, alguém poderia me passar como criar essa fórmula, um tutorial ou algo assim? Pois não faço a mínima idéia de como cria-la. Tenho uma fórmula criada em VBA aqui para outra função, mas já peguei ela pronta na internet do jeito que eu precisava.

Boa noite, pessoal! Estou em um impasse no meu código que passei o dia inteiro pesquisando e não consegui chegar em nenhuma luz. Possuo uma pasta dentro dos meus documentos hd, com uns 1000 e-mails do mesmo assunto e precisaria de uma maneira de filtrar palavras-chaves dentro do corpo do e-mail. No entanto, não estou conseguindo encontrar uma maneira de fazer o excel ler os arquivos de e-mails do Outlook dentro dessa pasta física (.msg). Tentei replicar o código presente nesse guia: Como Ler E-mails do Outlook e Colocar na Planilha com VBA (hashtagtreinamentos.com) No entanto, na variavel "minha_pasta" criei o objeto como file system object e acabou não dando certo. Desde já agradeço

Olá pessoal, tudo bem? Tenho uma planilha com macros para tratamento de dados e está habilitada para macros, porém, acontece um bug que ela simplesmente some com todos os códigos e não deixa salvar a plan. Aparecendo os erros abaixo e quando dou atl+F11 os módulos estão em branco. Já aconteceram 3x com planilhas diferentes. Ela funciona por um período e do Nada acontece esse erro. uso ela todos os dias para atualizar as bases de dados. Alguém já passou por um problema semelhante? Vlw, pessoal.

Boa tarde a todos do fórum! Venho tirar uma dúvida de VBA com vocês. É um trivial de copiar valores de um arquivo e colar em outro, porém tem um detalhe que está me travando, e vejo muitas dicas boas que tem ajudado a solucionar problemas aqui no fórum. Tenho um Excel com a aba Orig Tenho meu Excel destino já com a aba Dest o ultimo valor da Orig coluna B vai na primeira linha disponível da Dest coluna B, e escreva "Quantidade A" na célula da coluna A o ultimo valor da Orig coluna C vai na primeira linha disponível da Dest coluna B também, e escreva "Quantidade B" na célula da coluna A o ultimo valor da Orig coluna D vai na primeira linha disponível da Dest coluna B também, e escreva "Quantidade C" na célula da coluna A assim por diante, usando da coluna B até a coluna G da Orig. Caso o valor seja 0 (0,000 no caso da Orig), não deva colar este valor ou deva apagar apó s o código. Tenho já descrito o código que abre a janela, pede o Excel Orig para ser importado, ele copia os dados da aba Orig, porém cola tudo na Dest sem ser na ordem que desejava. Sub CopyQuant() Application.ScreenUpdating = False Dim flder As FileDialog Dim FileName As String Dim FileChosen As Integer Dim wkbSource As Workbook Dim wkbDest As Workbook Set wkbDest = ThisWorkbook Dim LastRowIndex As Integer Dim RowIndex As Integer Dim UsedRng As Range Dim npav As String Dim rangM As Range OpenFile: Set flder = Application.FileDialog(msoFileDialogFilePicker) flder.Title = "Arquivo" flder.InitialFileName = "c:\" flder.InitialView = msoFileDialogViewSmallIcons flder.Filters.Clear flder.Filters.Add "Excel Files", "*.xls*" MsgBox ("Selecione o arquivo") FileChosen = flder.Show FileName = flder.SelectedItems(1) Set wkbSource = Workbooks.Open(FileName) '''''''''''''''''''''''''''''''''''''''''''''''' 'DADOS PARA Dest wkbSource.Sheets("Orig").UsedRange.Copy ultimalinha = wkbDest.Sheets("Dest").Cells(Rows.Count, 1).End(xlUp).Row wkbDest.Sheets("Dest").Cells(wkbDest.Sheets("Dest").Rows.Count, "A").End(xlUp).Offset(ultimalinha + 1, 0).PasteSpecial xlPasteValues Alguém sabe como posso dar um passo a mais neste caso? Obrigado.

Olá a todos. Estou estudando VBA a pouco tempo, e estou fazendo um projeto de planilha solicitando que os funcionários PJ emitam as notas. Eu preciso enviar para o funcionário um e-mail com valor a receber, referente ao dia dos serviços prestados, e quando ele deve emitir a nota. O primeiro comando da programação é que SE a célula E ="valor" estiver vazia, não enviará o e-mail. Com a célula preenchida, ele seleciona o outlook app, coloca destinatário do e-mail, cc, título, imagem de corpo e texto. Porém eu preciso criar um novo SE - caso a célula G = "devolução" estiver preenchida, ele vai adicionar mais uma parte em texto ao corpo do e-mail. Não consigo fazer isso de jeito nenhum. Outro problema que tenho também é que ao colocar em Display, ele passa por todos os e-mails que precisam ser exibidos e termina no último e-mail, em uma unica aba. Exemplo, se eu tiver 10 e-mails pra mandar, ele vai exibir todos os emails rapidamente em uma guia só, e não abrir 10 guias; Coloco a programação aqui e a planilha em anexo para quem puder me ajudar. (obviamente as imagens no corpo do e-mail não funcionarão pois estão apontando o caminho da minha máquina) Agradeço desde já Sub Enviar_Email() Dim OutlookApp As Object Dim OutlookMail As Object Set OutlookApp = CreateObject("Outlook.Application") Set OutlookMail = OutlookApp.createitem(0) Dim png As String On Error Resume Next For linha = 1 To 5 If Teste.Range("E" & linha + 4).Value <> "" Then With OutlookMail .To = Teste.Range("C" & linha + 4).Value .CC = "recursoshumanos@empresa.com" & " financeiro@empresa.com" .Subject = "NF | Trabalho PJ - " & Teste.Range("B" & linha + 4).Value png = ThisWorkbook.Sheets("PJ").Range("H" & linha + 4).Value texto1 = "<body style = font-size:12pt>" & "Olá " & Teste.Range("B" & linha + 4).Value & ", tudo bem?" & "<br>" & "Segue abaixo suas participações no período de: " & Teste.Range("D" & linha + 4).Value texto2 = "<body style = font-size:14pt>" & "Valor:<b><u> R$" & Teste.Range("E" & linha + 4).Value & ",00 </b></u>" & "<br>" texto3 = "<body style = font-size:12pt>" & "Estando corretas, favor me encaminhar a NF entre os dias <b><u> " & Teste.Range("F" & linha + 4).Value & "</b></u>." texto4 = "<body style = font-size:12pt>" & "Cumprindo acordo, estamos descontando <b>R$ " & Teste.Range("G" & linha + 4) & ",00 </b> do seu pagamento, tudo bem?" texto5 = "<body style = font-size:12pt>" & "Se precisar de mim, sigo a disposição." & "<br>" & "Abraços," .htmlbody = texto1 & "<br><br>" & "<img src=" & Chr(34) & png & Chr(34) & ">" & "<br><br>" & texto2 & "<br>" & texto3 & "<br><br>" & texto5 .display End With End If Next linha On Error GoTo 0 Set OutlookApp = Nothing Set OutlookMail = Nothing End Sub ------------ Já tentei If Teste.Range("G" & linha + 4).Value = "" Then .htmlbody = texto1 & "<br><br>" & "<img src=" & Chr(34) & png & Chr(34) & ">" & "<br><br>" & texto2 & "<br>" & texto3 & "<br><br>" & texto5 Else .htmlbody = texto1 & "<br><br>" & "<img src=" & Chr(34) & png & Chr(34) & ">" & "<br><br>" & texto2 & "<br>" & texto3 & "<br>" & texto4 & "<br><br>" & texto5 E não foi... Sempre dá erro no With, no If, etc. ENVIEI UM GIF COM O PROBLEMA DO E-MAIL LInk pra Planilha: https://drive.google.com/file/d/1jpKBmdmnTMUIKZNx9I7pJI31vdpFgV8e/view?usp=sharing

Gleyson 0 Publicado 3 horas atrás Como criar um formulário onde tenha um Combobox de cargos... em que ele abre uma ListBox com os nomes dos Cargos... podendo clicar em várias linhas (ao mesmo tempo) da ListBox para excluir alguns cargos e apagar na Planilha?

Olá, Para quem puder me auxiliar, estou tentando montar uma macro e acionar por um botão para que faça o seguinte: • Pegar as informações de uma tabela simples e transpor os dados como nos exemplos. • Como essa tabela é dinâmica o número de colunas pode variar assim como as linhas. • A intenção é que cada cabeçalho da coluna entre novamente como título das linhas que estão na sequência. Tabela Original Tabela com dados transpostos Alguém pode me sugerir como fazer isso? Desde já, grato.

Olá pessoa, estou com um problema aqui. O código não consegue ler a linha caso tenha uma LETRA no caminho dele, vou dar um exemplo. A B C D 1 ola mundo 2 01/02/2021 200 200 3 se não tiver as palavras "ola" e "mundo" ele consegue fazer o calculo, vai descendo ate achar os valores 200,200 mas caso eu escreve qualquer coisa no caminho dele, ele não consegue calcular. Desde já agradeço. Codigo: Sub somarValores() On Error GoTo fim Dim data As Date Dim linha As Long Dim soma As Double Dim valor1, valor2 As Double soma = 0 caixa = 0 safra = 0 bb = 0 linha = 2 dataInicial = CDate(Planilha1.Cells(2, "F").Value) dataFinal = CDate(Planilha1.Cells(2, "F").Value) While Planilha1.Cells(linha, 1).Value <> "30/02/2021" valor1 = CDbl(Planilha1.Cells(linha, "B").Value) valor2 = CDbl(Planilha1.Cells(linha, "C").Value) 'se a data da coluna 1 estiver entre a dataInicia e dataFinal' If CDate(Planilha1.Cells(linha, 1).Value) >= dataInicial And CDate(Planilha1.Cells(linha, 1)) <= dataFinal Then 'somar valores' soma = soma + valor1 + valor2 End If 'passa para a proxima linha' linha = linha + 1 Wend 'coloca o valore da soma na coluna 10 da linha 2' Planilha1.Cells(2, 7) = soma Exit Sub fim: MsgBox "Não Foi possivel efetuar a soma" End Sub

Boa noite, estou iniciando no mundo do VBA no Excel e ainda não sei como realizar uma operação automática: A ideia é: assim que eu colar um conjunto de dados (cada dado com um conteúdo/nome padrão [001, 002... 009...] correspondente com a coluna A) da coluna hipotética X, eu quero que a célula exatamente à direita de cada dado respectivo copiado na coluna X vá pra uma posição exata na coluna B: Coluna A Coluna B Coluna X Direita de X 001. 002. Valor Z 002. Valor Z 004. Valor C 003. 009. Valor M 004. Valor C 005 ... 008 009. Valor M OBS: os nomes colados na coluna X sempre terão alguma correspondência com os nomes da coluna A (sempre serão códigos fixos) Alguém poderia me explicar como conseguir realizar esse processo? Muito obg!