ViníciusMG88

3 de agosto de 2020

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

10 de agosto de 2018

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

28 de junho de 2017

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

10 de fevereiro de 2015

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

Entrar

ViníciusMG88

Posts

Cadastrado em

Última visita

Tipo de conteúdo

Artigos

Selos

Fabricantes

Livros

Cursos

Análises

Fórum

posts postados por ViníciusMG88

Planilha Resumo - Buscar dados de várias abas e copiar para uma aba Resumo

copiar dados de várias pastas de trabalhos diferentes

inserção de linhas no módulo de layout de quebra de páginas - excel vba

Macro para envio de e-mail

Sobre o Clube do Hardware

Direitos autorais

Mais

Fórum

Atividades

Artigos

Análises

Livros

Cursos