Ir ao conteúdo
  • Cadastre-se

ViníciusMG88

Membro Júnior
  • Posts

    4
  • Cadastrado em

  • Última visita

Reputação

0
  1. Meus amigos, boa tarde! Já procurei em vários sites uma solução para meu problema e não tive sucesso. É o seguinte: Tenho uma planilha de orçamento onde ela tem várias abas de composições de serviços. Eu preciso de alguma forma separar os valores de equipamentos, materiais e outros em uma relação em abas específicas. Porém para funcionar de forma correta, por exemplo: se na planilha 1.1 eu tenho o equipamento betoneira e também na planilha 5.4 eu tenho o mesmo equipamento, preciso que na aba equipamentos apareça uma única linha de betoneira, porém somada as quantidades e valores das duas ou mais abas que tiver o mesmo equipamento, desde que seja a mesma unidade de medição, caso a unidade de medição for diferente, por exemplo um é dia e o outro é hora, aí eu preciso que apareça duas linhas de betoneira com os valores localizados em todas as demais abas. Não sei se conseguiram entender, mas é um pouco difícil de explicar por aqui... vou enviar a planilha para conseguirem entender melhor. Desde já agradeço.... QQP.xlsx
  2. Boa tarde pessoal! Gostaria de uma ajuda se possível, pois eu não entendo muito bem de VBA. Estou querendo criar um código onde eu tenho uma planilha "Resumo dos Ensaios" em uma pasta de trabalho. E também possuo várias outras pastas de trabalho onde servirão de origem para os dados a serem copiados para a planilha resumo dos ensaios (destino). Eu já até conseguir fazer funcionar com um código que achei na internet e fui alterando. Porém esta planilha "Resumo dos Ensaios" possui em média 22 colunas que deveriam ser preenchidas por outras 22 pastas de trabalho diferentes. Do jeito que eu fiz até agora, está funcionando para 3 colunas, ou seja para 3 pastas de trabalho. Eu consigo fazer para todas as 22, porém do jeito que estou fazendo o código vai ficar enorme. Eu queria fazer um código mais simples, onde ele automaticamente entendesse que caso exista as planilhas 001, 002, 003, 004... (e por aí vai...) dentro de uma pasta específica, as colunas sejam preenchidas com os dados corretos. E caso não exista todas as 22 dentro da pasta, ele só preenche a mesma quantidade de colunas de planilhas existentes. Não sei se conseguir explicar direito. Mas vou enviar o código e a planilha em anexo para vocês tentarem me entender e me ajudar da melhor forma possível. Desde já agradeço a todos! Sub IMPORTAÇÃO() Application.ScreenUpdating = False Dim wsOrigem As Worksheet Dim wsDestino As Worksheet Workbooks.Open Filename:="C:\Users\Vinicius.Nascimento\Desktop\TESTE\001.xlsx" Set wsOrigem = Workbooks("001.xlsx").Worksheets("RESUMO") Set wsDestino = Workbooks("RESUMO DOS ENSAIOS.xlsm").Worksheets("RESUMO") wsDestino.Range("E7").Value = wsOrigem.Range("F10").Value wsDestino.Range("E8").Value = wsOrigem.Range("F11").Value wsDestino.Range("E9").Value = wsOrigem.Range("F12").Value wsDestino.Range("E10").Value = wsOrigem.Range("F13").Value wsDestino.Range("E11").Value = wsOrigem.Range("F33").Value wsDestino.Range("E12").Value = wsOrigem.Range("F16").Value wsDestino.Range("E13").Value = wsOrigem.Range("F17").Value wsDestino.Range("E14").Value = wsOrigem.Range("F18").Value wsDestino.Range("E15").Value = wsOrigem.Range("F19").Value wsDestino.Range("E16").Value = wsOrigem.Range("F20").Value wsDestino.Range("E17").Value = wsOrigem.Range("F21").Value wsDestino.Range("E18").Value = wsOrigem.Range("F22").Value wsDestino.Range("E19").Value = wsOrigem.Range("F23").Value wsDestino.Range("E20").Value = wsOrigem.Range("F24").Value wsDestino.Range("E21").Value = wsOrigem.Range("F25").Value wsDestino.Range("E22").Value = wsOrigem.Range("F26").Value wsDestino.Range("E23").Value = wsOrigem.Range("F27").Value wsDestino.Range("E24").Value = wsOrigem.Range("F28").Value wsDestino.Range("E25").Value = wsOrigem.Range("F29").Value wsDestino.Range("E26").Value = wsOrigem.Range("F34").Value wsDestino.Range("E27").Value = wsOrigem.Range("F35").Value wsDestino.Range("E31").Value = wsOrigem.Range("F31").Value wsDestino.Range("E32").Value = wsOrigem.Range("F37").Value wsDestino.Range("E33").Value = wsOrigem.Range("F36").Value wsDestino.Range("E34").Value = wsOrigem.Range("F32").Value Workbooks("001.xlsx").Close SaveChanges:=True Workbooks.Open Filename:="C:\Users\Vinicius.Nascimento\Desktop\TESTE\002.xlsx" Set wsOrigem = Workbooks("002.xlsx").Worksheets("RESUMO") Set wsDestino = Workbooks("RESUMO DOS ENSAIOS.xlsm").Worksheets("RESUMO") wsDestino.Range("F7").Value = wsOrigem.Range("F10").Value wsDestino.Range("F8").Value = wsOrigem.Range("F11").Value wsDestino.Range("F9").Value = wsOrigem.Range("F12").Value wsDestino.Range("F10").Value = wsOrigem.Range("F13").Value wsDestino.Range("F11").Value = wsOrigem.Range("F33").Value wsDestino.Range("F12").Value = wsOrigem.Range("F16").Value wsDestino.Range("F13").Value = wsOrigem.Range("F17").Value wsDestino.Range("F14").Value = wsOrigem.Range("F18").Value wsDestino.Range("F15").Value = wsOrigem.Range("F19").Value wsDestino.Range("F16").Value = wsOrigem.Range("F20").Value wsDestino.Range("F17").Value = wsOrigem.Range("F21").Value wsDestino.Range("F18").Value = wsOrigem.Range("F22").Value wsDestino.Range("F19").Value = wsOrigem.Range("F23").Value wsDestino.Range("F20").Value = wsOrigem.Range("F24").Value wsDestino.Range("F21").Value = wsOrigem.Range("F25").Value wsDestino.Range("F22").Value = wsOrigem.Range("F26").Value wsDestino.Range("F23").Value = wsOrigem.Range("F27").Value wsDestino.Range("F24").Value = wsOrigem.Range("F28").Value wsDestino.Range("F25").Value = wsOrigem.Range("F29").Value wsDestino.Range("F26").Value = wsOrigem.Range("F34").Value wsDestino.Range("F27").Value = wsOrigem.Range("F35").Value wsDestino.Range("F31").Value = wsOrigem.Range("F31").Value wsDestino.Range("F32").Value = wsOrigem.Range("F37").Value wsDestino.Range("F33").Value = wsOrigem.Range("F36").Value wsDestino.Range("F34").Value = wsOrigem.Range("F32").Value Workbooks("002.xlsx").Close SaveChanges:=True Workbooks.Open Filename:="C:\Users\Vinicius.Nascimento\Desktop\TESTE\003.xlsx" Set wsOrigem = Workbooks("003.xlsx").Worksheets("RESUMO") Set wsDestino = Workbooks("RESUMO DOS ENSAIOS.xlsm").Worksheets("RESUMO") wsDestino.Range("G7").Value = wsOrigem.Range("F10").Value wsDestino.Range("G8").Value = wsOrigem.Range("F11").Value wsDestino.Range("G9").Value = wsOrigem.Range("F12").Value wsDestino.Range("G10").Value = wsOrigem.Range("F13").Value wsDestino.Range("G11").Value = wsOrigem.Range("F33").Value wsDestino.Range("G12").Value = wsOrigem.Range("F16").Value wsDestino.Range("G13").Value = wsOrigem.Range("F17").Value wsDestino.Range("G14").Value = wsOrigem.Range("F18").Value wsDestino.Range("G15").Value = wsOrigem.Range("F19").Value wsDestino.Range("G16").Value = wsOrigem.Range("F20").Value wsDestino.Range("G17").Value = wsOrigem.Range("F21").Value wsDestino.Range("G18").Value = wsOrigem.Range("F22").Value wsDestino.Range("G19").Value = wsOrigem.Range("F23").Value wsDestino.Range("G20").Value = wsOrigem.Range("F24").Value wsDestino.Range("G21").Value = wsOrigem.Range("F25").Value wsDestino.Range("G22").Value = wsOrigem.Range("F26").Value wsDestino.Range("G23").Value = wsOrigem.Range("F27").Value wsDestino.Range("G24").Value = wsOrigem.Range("F28").Value wsDestino.Range("G25").Value = wsOrigem.Range("F29").Value wsDestino.Range("G26").Value = wsOrigem.Range("F34").Value wsDestino.Range("G27").Value = wsOrigem.Range("F35").Value wsDestino.Range("G31").Value = wsOrigem.Range("F31").Value wsDestino.Range("G32").Value = wsOrigem.Range("F37").Value wsDestino.Range("G33").Value = wsOrigem.Range("F36").Value wsDestino.Range("G34").Value = wsOrigem.Range("F32").Value Workbooks("003.xlsx").Close SaveChanges:=True Application.ScreenUpdating = True End Sub RESUMO DOS ENSAIOS.xlsx
  3. Amigos, boa tarde! Estou quebrando cabeça com um código VBA mais não consigo uma solução. Possuo uma planilha que tem várias páginas (em torno de 53) e que estas irão variar dia a dia com a inserção de dados. Este código insere uma linha e realiza o cálculo do "SUBTOTAL" em todas as quebras de página, sendo que na última página deve conter o "SUBTOTAL" e o "TOTAL" geral (neste caso inserindo duas linhas na última página). No início chegou até funcionar com uma certa quantidade de linhas. Na planilha em anexo eu inserir 20 dados (linhas) a mais no final e executei a macro, porém após esta inserção de dados, o "SUBTOTAL" e o "TOTAL" que deveria ficar na última página (sendo as últimas duas linhas) está dando erro, pois está ficando na penúltima página. Obs.: Vocês podem por exemplo fazer o teste excluindo as últimas 20 linhas da planilha e executar a macro e verificar que desta maneira a macro é executada da forma correta. Caso possam me ajudar, o código em questão é: Sub Inserir_subtotais_em_quebra_paginas() Dim i As Long Dim vUltima_Linha As Long, vLinha As Long, vPagina As Long Dim LinhaDaSoma As Long Dim TextoFormula As String vLinha = 14 vUltima_Linha = Range("N1048576").End(xlUp).Row ActiveSheet.HPageBreaks.Add Before:=Cells(vUltima_Linha + 1, 14) Application.ScreenUpdating = False For i = 1 To ActiveSheet.HPageBreaks.Count + 1 vPagina = ActiveSheet.HPageBreaks(i).Location.Row - 1 - (i = ActiveSheet.HPageBreaks.Count) If i = ActiveSheet.HPageBreaks.Count Then ActiveSheet.PageSetup.PrintArea = "$B$2:$P$" & vPagina + 1 Range("B" & vPagina - 1 & ":P" & vPagina - 1).Select Selection.Copy Range("B" & vPagina & ":P" & vPagina + 1).Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("B" & vPagina).Select ActiveSheet.HPageBreaks(i).DragOff Direction:=xlDown, RegionIndex:=1 GoTo Fim End If Rows(vPagina).Insert Fim: With Cells(vPagina, 14) LinhaDaSoma = vPagina - 1 .FormulaLocal = "=Soma(N" & vLinha & ":N" & LinhaDaSoma & ")" Range("M" & vPagina) = "SUBTOTAL" .Interior.ColorIndex = 3 End With vLinha = vPagina + 1 Next i vUltima_Linha = Range("N1048576").End(xlUp).Row For i = 14 To vUltima_Linha If Range("M" & i).Value = "SUBTOTAL" Then If i < 52 Then TextoFormula = "N" & i Else TextoFormula = TextoFormula & "+N" & i End If End If Next With Cells(vPagina + 1, 14) .FormulaLocal = "=SOMA(" & TextoFormula & ")" Range("M" & vPagina + 1) = "TOTAL" .Interior.ColorIndex = 5 End With Application.ScreenUpdating = True End Sub Segue também planilha teste em anexo para melhor visualização do erro. PLANILHA TESTE.rar
  4. Boa tarde Pessoal! Se possível gostariam que me ajudassem. Não entendo praticamente nada de macro. Porém com algumas pesquisas na internet conseguir fazer uma planilha que já quebrou meu galho. A planilha envia um e-mail das coisas que estão pendentes. Ela exibe uma pergunta no início para enviar ou não o e-mail. Está tudo funcionando normal. Só que eu gostaria de quando eu clicar em SIM, ela enviar o e-mail e também colocar em uma determinada coluna (qualquer) a palavra "Envidado". Para que outra vez que eu abrir a planilha e ela me pedir para enviar os e-mails, ela não enviar novamente o que já foi enviado. Se puderem me ajudar agradeço. o código é o seguinte: 'Enviar emailSub Enviar_email(ByVal lEndereco As String, ByVal lTarefa As String, ByVal lData As String) Dim enderecos As Range Dim celula As Range Dim anexo As String Dim r As Integer Dim fim Dim enviar Dim objOlAppApp As Outlook.Application Dim objOlAppMsg As Outlook.MailItem Dim objOlAppRecip As Outlook.Recipient Dim objOlAppAnexo As Outlook.Attachment 'Criar objeto do outlook Set objOlAppApp = CreateObject("Outlook.Application") Set objOlAppMsg = objOlAppApp.CreateItem(olMailItem) With objOlAppMsg 'Email do destinatário Set objOlAppRecip = .Recipients.Add(lEndereco) objOlAppRecip.Type = olTo 'Grau de importância do email .Importance = olImportanceHigh 'Cabeçalho do email .Subject = "VENCIMENTO DE CALIBRAÇÃO - " & lTarefa & "" 'Texto do email .Body = "Prezados," & vbCrLf & _ vbCrLf & "A calibração referente ao equipamento " & lTarefa & " irá vencer no dia " & lData & ". Favor programar a calibração do mesmo junto ao Escritório da Qualidade." & vbCrLf & _ vbCrLf & "Cordialmente," & vbCrLf & vbCrLf & _ "Vinícius" & vbCrLf & "Técnico Analista da Qualidade" & vbCrLf & "Engenharia." & vbCrLf & "Telefone: (27)" 'Enviar email .Send End With 'Liberar variáveis Set objOlAppApp = Nothing Set objOlAppMsg = Nothing Set objOlAppAnexo = Nothing Set objOlAppRecip = NothingEnd Sub'Enviar emails das pendênciasSub lsEnviarAtrasos() Dim iTotalLinhas As Long Dim i As Long Dim lHoje As Date Worksheets("CONTROLE DE CALIBRAÇÃO").Select Cells(2, 1).Select iTotalLinhas = Cells(Rows.Count, 2).End(xlUp).Row + 1 i = 3 While i < iTotalLinhas If Cells(i, 16).Value <= Range("V3").Value Then Enviar_email Cells(i, 21).Value, Cells(i, 10).Value, Cells(i, 16).Value End If i = i + 1 WendEnd Sub'Enviar emails e fechar aplicaçãoSub lsValidaEnvio() If MsgBox("Deseja verificar as pendências e enviar por e-mail?", vbYesNo, "CONTROLE DE CALIBRAÇÃO") = vbYes Then lsEnviarAtrasos End IfEnd Sub

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×
×
  • Criar novo...