AfonsoMira

@Osmarbg Boas, essa pessoa em específico para quem envia email, está usando um MAC ou Windows?

@Formactory Windows Informa Então peço desculpas pela demora: Se entendi tudo certo, penso que seja isto que deseja: Controle de estoque.zip

@Formactory Windows Informa Boas veja se o seguinte exemplo que desenvolvi lhe ajuda. Caso precise de algo mais específico, por favor envie um exemplo de ficheiro para poder fazer á sua medida. subtrair produto.zip

@Maxfdias Ora essa foi um prazer ajudar. Não se esqueça de curtir a resposta como forma de agradecimento . Obrigado!

@Maxfdias Obrigado, por disponibilizar o ficheiro. Estive a ver o seu ficheiro e decidi retirar o código no evento change e adicionalo ao botão de pesquisa que utiliza para efetuar o filtro. Veja se é este o resultado que espera. Gestão de Frota 2.1 - Afonso Mira.xlsm.zip

Pode disponibilizar a planilha para eu poder testar nela? Obrigado!

@Maxfdias Ora experimente desta forma: Private Sub Worksheet_Change(ByVal Target As Range) Dim ultimaLinha As Long ultimaLinha = ActiveSheet.Cells(Rows.Count, 29).End(xlUp).Row Application.EnableEvents = False Application.ScreenUpdating = False For i = 10 To ultimaLinha 'Verificar se a cécula do Ôdometro está Vazia If Cells(i, 30) = "" Then 'Limpar a célula (KM RODADO)se a céclula Ôdometro etiver vazia Cells(i, 31) = "" Else 'Adicionar fórmula para calculo de (KM RODADO) Cells(i, 31).FormulaArray = "=IFERROR(RC[-1]-INDIRECT(""AD""&LARGE(IF(R10C24:RC[-7]=RC[-7],ROW(R10C24:RC[-7])),2)),""0"")" End If Next i Application.EnableEvents = True Application.ScreenUpdating = True End Sub Caso continue sem funcionar, utilize antes este código: Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False For i = 10 To 500 'Verificar se a cécula do Ôdometro está Vazia If Cells(i, 30) = "" Then 'Limpar a célula (KM RODADO)se a céclula Ôdometro etiver vazia Cells(i, 31) = "" Else 'Adicionar fórmula para calculo de (KM RODADO) Cells(i, 31).FormulaArray = "=IFERROR(RC[-1]-INDIRECT(""AD""&LARGE(IF(R10C24:RC[-7]=RC[-7],ROW(R10C24:RC[-7])),2)),""0"")" End If Next i Application.EnableEvents = True Application.ScreenUpdating = True End Sub

@Maxfdias Boas veja se com este código consegue. Private Sub Worksheet_Change(ByVal Target As Range) Dim ultimaLinha As Long ultimaLinha = ActiveSheet.Cells(Rows.Count, 30).End(xlUp).Row Application.EnableEvents = False Application.ScreenUpdating = False For i = 10 To ultimaLinha 'Verificar se a cécula do Ôdometro está Vazia If Cells(i, 30) = "" Then 'Limpar a célula (KM RODADO)se a céclula Ôdometro etiver vazia Cells(i, 31) = "" Else 'Adicionar fórmula para calculo de (KM RODADO) Cells(i, 31).FormulaArray = "=IFERROR(RC[-1]-INDIRECT(""AD""&LARGE(IF(R10C24:RC[-7]=RC[-7],ROW(R10C24:RC[-7])),2)),""0"")" End If Next i Application.EnableEvents = True Application.ScreenUpdating = True End Sub

@DECOVIOTI Boas tudo bem, Veja se este código lhe ajuda. Sub CriarPowerPoint() 'Adicione a referencia Microsoft PowerPoint X.0 Object Library: '1. Va a Tools no menu do VBA '2. Clique em referencias '3. Desça um pouco até encontrar "Microsoft PowerPoint X.0 Object Library", marque a caixa e clique Okay 'Primeiro declaramos as variaveis Dim newPowerPoint As PowerPoint.Application Dim activeSlide As PowerPoint.Slide Dim cht As Excel.ChartObject 'Desativa o update de ecrã Application.ScreenUpdating = False 'Verificamos se não existem powerPoints abertos On Error Resume Next Set newPowerPoint = GetObject(, "PowerPoint.Application") On Error GoTo 0 'Criamos um novo powerpoint If newPowerPoint Is Nothing Then Set newPowerPoint = New PowerPoint.Application End If 'Criamos a apresentação no powerPoint If newPowerPoint.Presentations.Count = 0 Then newPowerPoint.Presentations.Add End If 'Mostra o PowerPoint newPowerPoint.Visible = True 'Conta Abas For i = 1 To 11 'Loop por todos os gráficos da folha e cola os no PowerPoint For Each cht In Sheets(i).ChartObjects 'Adiciona um novo slide onde vai colar o gráfico newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) 'Copia o gráfico e coloa no PowerPoint cht.Select ActiveChart.ChartArea.Copy activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select 'Deixa o título do slide igual ao título do gráfico activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text 'Alinha título do slide ao centro activeSlide.Shapes(1).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter 'ajusta as posições do gráfico no slide newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15 newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125 activeSlide.Shapes(2).Width = 600 activeSlide.Shapes(2).Left = 200 Next Next i 'Ativa o update de ecrã Application.ScreenUpdating = True Set activeSlide = Nothing Set newPowerPoint = Nothing End Sub Ps. Tem que adicionar o "Microsoft PowerPoint X.0 Object Library" nas referencias do VBA.

Boas, tudo bem. Como exatamente os valores de AD atualizam? Um por um , todos de uma vez ou aleatóriamente? Obrigado!

Boas voce pode utilizar esta formatação costumizada. _-* #,##0.00_-;-* #,##0.00_-;_-* ""??_-;_-@_-

Boas, Para podermos ajudar melhor, por favor anexe o ficheiro.

De nada! Ainda bem que pude ajudar.

Boas veja se é isto que pretende? contagem.xlsx

Não se esqueça de marcar a resposta correta como resolvido. Abraço.

De nada é sempre um prazer ajudar. Viu foi minha prenda de aniversário e eu nem sabia. kkkk Abraço amigo.

Veja se assim ajuda? Recorrer impressão rev03 AfonsoMira.zip

Então penso que com tudo no low a 640 de resolução consiga rodar com uma média de 30 fps sim. Deixo aqui um site onde consegue ver os jogos que a sua config roda não estão totalmente corretos mas dá para tirar uma ideia. https://www.game-debate.com/gaming-pc/index.php?r_id=628872&cpu=Athlon II X2 250&gpu=GeForce 7025 nForce 630a&ram=2GB#

Olá bem-vindo. Veja se é isto que pretende? relatório.xlsx

Boas tudo bem. Veja se ao correr este código resolve o seu problema. Basta abrir o ficheiro e clicar no botão "ABRIR VBE" que em príncipio o VBE irá abrir. Abrir VBE.zip

Boas tudo bem. Estive a estudar o seu caso e apenas consegui chegar nesta solução. Ela imprimi o número de etiquetas que inserir, porêm tem que ser sempre número par de etiquetas. Outro erro que não consigo resolver é quanto a questão da Area de impressão. Até 20 etiquetas ele seta a area de impressão individualmente em cada etiqueta. Mas caso sejam mais ele não faz isso, se álguem ai quiser alterar o meu código para resolver essa questão fique à vontade. Código: Sub Gerador() Dim quantidade As Long Dim i As Long Dim linhas As Integer Dim x As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False 'Apaga planilha ETIQUETAS se existir On Error Resume Next Sheets("ETIQUETAS").Delete 'Seleciona Menu e vai buscar a quantidade de etiquetas Sheets("MENU").Select quantidade = Sheets("MENU").Range("F20") 'Torna planilha "PADRÃO" visivel, copia, cola e altera nome para "ETIQUETAS" Sheets("DADOS").Select Sheets("PADRÃO").Visible = True Sheets("PADRÃO").Select Sheets("PADRÃO").Copy Before:=Sheets(2) Sheets("PADRÃO").Visible = False Sheets("PADRÃO (2)").Name = "ETIQUETAS" 'Copia as células para criar as etiquetas For i = 6 To quantidade Step 2 Rows("2:8").Select Selection.Copy Rows("2:2").Select Selection.Insert Shift:=xlDown Rows("2:2").Select ActiveWindow.SmallScroll Down:=-12 Range("G2:J7").Select Range("J2").Activate Application.CutCopyMode = False Next i linhas = quantidade / 2 linhas = linhas * 7 'Seleciona o range para colocar na print area, não sei o porque mas a partir de 20 etiquetas ele não seta o range For x = 2 To linhas Step 7 myRange = myRange & "$B$" & x & ":$E$" & x + 5 & "," & "$G$" & x & ":$J$" & x + 5 & "," Next x myRange = Left(myRange, Len(myRange) - 1) Sheets("ETIQUETAS").PageSetup.PrintArea = "" Sheets("ETIQUETAS").PageSetup.PrintArea = myRange Range("A1").Select Application.EnableEvents = True Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "Etiquetas geradas com sucesso!" End Sub

Boas pelo que fiquei a perceber daquilo que colocou, cheguei a este resultado. Ora veja se é isto que pretende. Problema_Afonso.xlsx

Boas veja se assim ajuda? Formula SE Exemplo Afonso.xlsx

Boas amigo, Seria isto ao invés de ele escrever o código na célula B1 vai escrever na Célula A1 e assim já vai buscar o nome do produto. Ficheiro em anexo. Cópia de Etiquetas.zip

Não percebi bem o que pretende. Você quer invés de colocar aqui o código colocar o nome do produto?