Leo P Costa

consegui criar uma formula, segue ela:

sub somar()

range("e3").activate

for each celula in range("e3:teste")

    soma = soma + celula.value 'pega e soma o valor da celula
    
    if soma >= 600 then
    activecell.interior.colorindex = 3 'aqui deixa o fundo da celular selecionada vermelha
    soma = soma - 600  'aqui tira a diferença
    else
    activecell.interior.colorindex = 0 'aqui deixa o fundo da celular selecionada branca
    end if
    
    activecell.offset(1, 0).activate 'passa pra proxima celula
    
next
end sub

 

Boa tarde. Gostaria de saber se tem alguma forma de formatar ou criar alguma formula quando em uma planilha atinge determinado valor.

Vou explicar melhor:

Tenho uma planilha onde lanço os pedidos de um cliente, na coluna do valor eu tenho a soma total no final, mas gostaria de saber se durante os lançamentos dos valores, tem como eu formatar para que uma das celulas com o valor lançado ficasse em vermelho quando atingisse um determinado valor, tipo 600,00.

Exemplo:

 

Os valores são lançados na coluna E

E3 = 100,00

E4: = 100,00

E5: = 200,00

E6: = 200,00 (esse valor ficasse em vermelho)

E7: = 300,00

E8: = 200,00

E9: = 100,00 (Esse valor ficasse em vermelho)

E10: = 50,00

E11: = 100,00

E12: = 35,00

E13: = 40,00

E14: = 50,00

E15: = 100,00

E16: = 50,00

E17: = 35,00

E18: = 35,00

E19: = 75,00

E20: = 65,00 (Esse valor ficasse em vermelho)

E21: = (soma total)

 

ou seja, a cada 600,00 a ultima que daria ou completasse a soma de 600,00 ficasse em vermelho, pois nem sempre a soma será de 600,00 redondo, pode ser que passe um pouco.

Anexei a tabela que uso para os clientes.

 

Fico no aguardo. Obrigado.

RELAÇÃO CLIENTE - Cópia.rar

Boa tarde. Consegui resolver o meu problema, era apenas o nome de uma das TextBox que estava errado.

Obrigado

Boa noite. Estou com um codigo de um formulario, sempre que vou rodar ele gera um erro de tempo de execução 424, segue codigo. Mas ele não mostra onde está o erro.

Private Linha As IntegerPublic GravarAlterar As IntegerPrivate Sub Atualiza_Form()    Cells(Linha, 1).Activate    Txt_Cartao.Value = Cells(Linha, 1)    Txt_Data.Value = Cells(Linha, 2)    Txt_Descricao.Value = Cells(Linha, 3)    Txt_Valor.Value = Cells(Linha, 4)    Txt_Pgnt.Value = Cells(Linha, 5)    Txt_Quantidade.Value = Cells(Linha, 6)End SubPrivate Sub Cmd_Alterar_Click()If Txt_Cartao.Value = "" ThenMsgBox "Selecione o registro", vbCritical, "Erro"ElseGravarAlterar = 2Frame1.Enabled = TrueCmd_Anterior.Enabled = FalseCmd_Proximo.Enabled = FalseCmd_Incluir.Enabled = FalseCmd_Alterar.Enabled = FalseCmd_Gravar.Enabled = TrueCmd_Cancelar.Enabled = TrueCmd_Excluir.Enabled = FalseEnd IfEnd SubPrivate Sub Cmd_Anterior_Click()Linha = ActiveCell.RowIf Linha < 6 ThenLinha = Linha - 1Atualiza_FormElseAtualiza_FormMsgBox "Primeiro Registro", vbInformation, "Planilha de Despesas"End IfEnd SubPrivate Sub Cmd_Cancelar_Click()Call UserForm_InitializeEnd SubPrivate Sub Cmd_Excluir_Click()Dim del As StringIf ActiveCell.Value = "" ThenMsgBox "Selecione um registro para exclusão", vbCritical, "Erro de Operação"ElseIf ActiveCell.Value <> "" Thendel = (MsgBox("Deseja excluir o registro ativo?" & Me.Txt_Cartao & " " & _Me.Txt_Descricao, vbYesNo + vbQuestion, "Exclusão de Dados"))If del = vbYes ThenActiveCell.EntireRow.DeleteLinha = Linha - 1Call UserForm_InitializeElseMsgBox "Operação cancelada", vbInformation, "Planilha de Despesas"Call UserForm_InitializeEnd IfEnd IfEnd SubPrivate Sub Cmd_Gravar_Click()Select Case GravarAlterarCase Is = 1    If Txt_Cartao.Value = "" Then        MsgBox "Obrigatório preencher campo Cartão", vbCritical, "Erro"    ElseIf Txt_Data.Value = "" Then        MsgBox "Obrigatório preencher campo Data", vbCritical, "Erro"    ElseIf Txt_Descricao.Value = "" Then        MsgBox "Obrigatório preencher campo Descrição", vbCritical, "Erro"    ElseIf Txt_Valor.Value = "" Then        MsgBox "Obrigatório preencher campo Valor", vbCritical, "Erro"    ElseIf Txt_Quantidade.Value = "" Then        MsgBox "Obrigatório preencher campo Quantidade", vbCritical, "Erro"    ElseIf Cbo_Mes.Value = "" Then        MsgBox "Obrigatório preencher campo Mês", vbCritical, "Erro"    Else        While ActiveCell.Value <> ""        ActiveCell.Offset(1, 0).Select        Wend        Linha = ActiveCell.Row        Cells(Linha, 1) = Txt_Cartao.Value        Cells(Linha, 2) = Txt_Data.Value        Cells(Linha, 3) = Txt_Descricao.Value        Cells(Linha, 4) = Txt_Valor.Value        Cells(Linha, 6) = Txt_Quantidade.Value                UserForm_Initialize    End If    Case Is = 2        Cells(Linha, 1) = Txt_Cartao.Value        Cells(Linha, 2) = Txt_Data.Value        Cells(Linha, 3) = Txt_Descricao.Value        Cells(Linha, 4) = Txt_Valor.Value        Cells(Linha, 5) = Txt_Pgnt.Value        Cells(Linha, 6) = Txt_Quantidade.Value                UserForm_Initialize        MsgBox "Dados alterados com sucesso", vbInformation, "Planilha de Despesas"        End SelectEnd SubPrivate Sub Cmd_Incluir_Click()GravarAlterar = 1Me.Txt_Cartao.Value = ""Me.Txt_Data.Value = ""Me.Txt_Descricao.Value = ""Me.Txt_Valor.Value = ""Me.Txt_Pgnt.Value = ""Me.Txt_Quantidade.Value = ""Me.Cbo_Mes.Value = ""Frame1.Enabled = TrueFrame2.Enabled = TrueMe.Txt_Cartao.SetFocusCmd_Anterior.Enabled = FalseCmd_Proximo.Enabled = FalseCmd_Incluir.Enabled = FalseCmd_Alterar.Enabled = FalseCmd_Gravar.Enabled = TrueCmd_Cancelar.Enabled = TrueCmd_Excluir.Enabled = FalseEnd SubPrivate Sub Cmd_Proximo_Click()Linha = ActiveCell.RowIf Cells(Linha + 1, 1).Value <> "" ThenLinha = Linha + 1Atualiza_FormElseAtualiza_FormMsgBox "Último Registro", vbInformation, "Planilha de Despesas"End IfEnd SubPrivate Sub Cmd_Sair_Click()Dim sairsair = (MsgBox("Deseja fechar o cadastro de despesas de Janeiro?", vbYesNo + vbQuestion, "Planilha de Despesas"))If sair = vbYes ThenActiveWorkbook.SaveUnload MeFrm_Menu.ShowEnd IfEnd SubPrivate Sub UserForm_Initialize()Sheets("JANEIRO").SelectRange("A6").SelectTxt_Cartao.Value = ""Txt_Data.Value = ""Txt_Descricao.Value = ""Txt_Valor.Value = ""Txt_Pgnt.Value = ""Txt_Quantidade.Value = ""Frame1.Enabled = FalseFrame2.Enabled = TrueCmd_Anterior.Enabled = TrueCmd_Proximo.Enabled = TrueCmd_Incluir.Enabled = TrueCmd_Alterar.Enabled = TrueCmd_Gravar.Enabled = FalseCmd_Cancelar.Enabled = FalseCmd_Excluir.Enabled = TrueCbo_Mes.ClearWith Me.Cbo_Mes    .AddItem "Janeiro"    .AddItem "Fevereiro"    .AddItem "Março"    .AddItem "Abril"    .AddItem "Maio"    .AddItem "Junho"    .AddItem "Julho"    .AddItem "Agosto"    .AddItem "Setembro"    .AddItem "Outubro"    .AddItem "Novembro"    .AddItem "Dezembro"End WithWorksheets("JANEIRO").SelectRange("A6").SelectWhile ActiveCell.Value <> ""ActiveCell.Offset(1, 0).SelectWendDados = ActiveCell.RowLst_DespesaJaneiro.RowSource = Range(Cells(6, 1), Cells(Dados, 6)).AddressEnd SubPrivate Sub Cbo_Mes_Change()    If Cbo_Mes = "Fevereiro" Then        Unload Me        Frm_Fevereiro.Show    End If    End SubPrivate Sub Txt_Data_Change()If Txt_Data.TextLength = 2 Or Txt_Data.TextLength = 5 Then    Txt_Data.Text = Txt_Data.Text + "/"End If    End SubPrivate Sub Txt_Parcela_Change()If Txt_Parcela.TextLength = 2 Then    Txt_Parcela.Text = Txt_Parcela.Text + "/"End IfEnd SubPrivate Sub Txt_Pgnt_Exit(ByVal Cancel As MSForms.ReturnBoolean)    Txt_Pgnt = Format(Txt_Pgnt, "R$ #,##0.00")    End SubPrivate Sub Txt_Valor_Exit(ByVal Cancel As MSForms.ReturnBoolean)    Txt_Valor = Format(Txt_Valor, "R$ #,##0.00")    End Sub

Bom dia!

 

acho que tem como fazer uma gambiarra ai pra resolver....

 

você pega uma celula que você nunca vai precisar, sei l´tipo a XFD1

ai no vba de inserir codigo, você coloca um IF no inicio que se a celula XFD1 estiver vazia ele roda, se tiver prenchida ele nao faz nada!

 

e no codigo do botao, no inicio você cloca um

 

ranger("XFD1").value = "OK"

ou seja ela vai ta prenchida o outro nao vai rodar

 

e no final dele um

 

ranger("XFD1").value = clear

ela vai ta vazia o outro vai rodar normal...

 

tenta ai... vai que cola....

 

 

Funcionou perfeitamente. Obrigado

Para contornar o problema altere o comando que sugeri, coloque conforme abaixo.

If Target.Count > 3 Then Exit Sub

 

sugestão - não utilize o recurso "mesclar células", pois células mescladas podem provocar erro em macros e em fórmulas e normalmente são desnecessárias.

 

Já fiz esse teste, até que funciona para que o código seja inserido, mas ai o problema no botão de inserir linha volta, quando clico no botão aparece 4x para inserir o código.

A mesclagem foi necessário para a minha tabela, uma vez que quando coloca o código aparece o nome do produto, e ele geralmente e maior do que a célula.

Estou disponibilizando o relatório.

 

Relatorio Diario Muriaé - 2015.rar

 

Dentro do quadrado em negrito tem que aparecer uma inputbox para que seja inserido um código e não está aparecendo.

 

Acrescente a segunda linha abaixo no primeiro código.

...

Dim txtValor As Currency

If Target.Count > 1 Then Exit Sub

...

 

Tive que reabrir esse post, hoje abri o relatório e quando clico para inserir o código no meio do relatório, não aparece a inputbox para inserir o código.

Olá, Leo.

 

Sugiro que você disponibilize também o seu código que insere linha.

 

 

Aproveite para verificar/encerrar os dois tópicos abaixo que você abriu e abandonou.

 

http://forum.clubedohardware.com.br/forums/topic/1117364-dividir-caminho-absoluto-de-nome-do-arquivo/#entry6138483

 

http://forum.clubedohardware.com.br/forums/topic/1110934-macro/#entry6103504

Sub InserirLinhaRelatorio()' Inserindo linha no campo do Relatório    Application.ScreenUpdating = False            Sheets("Relatório").Unprotect ("2550")    Range("Vendas").Activate    ActiveCell.Offset(-1, 0).Select    Selection.EntireRow.Insert    Intersect(Selection.EntireRow, Range("D:F")).Select    With Selection        .HorizontalAlignment = xlCenter        .VerticalAlignment = xlCenter        .WrapText = False        .Orientation = 0        .AddIndent = False        .IndentLevel = 0        .ShrinkToFit = False        .ReadingOrder = xlContext        .MergeCells = False    End With    Selection.Borders(xlDiagonalDown).LineStyle = xlNone    Selection.Borders(xlDiagonalUp).LineStyle = xlNone    Selection.Merge        Intersect(Selection.EntireRow, Range("G:I")).Select    With Selection        .HorizontalAlignment = xlCenter        .VerticalAlignment = xlCenter        .WrapText = False        .Orientation = 0        .AddIndent = False        .IndentLevel = 0        .ShrinkToFit = False        .ReadingOrder = xlContext        .MergeCells = False    End With    Selection.Borders(xlDiagonalDown).LineStyle = xlNone    Selection.Borders(xlDiagonalUp).LineStyle = xlNone    Selection.Merge    Intersect(Selection.EntireRow, Range("J:L")).Select    With Selection        .HorizontalAlignment = xlCenter        .VerticalAlignment = xlCenter        .WrapText = False        .Orientation = 0        .AddIndent = False        .IndentLevel = 0        .ShrinkToFit = False        .ReadingOrder = xlContext        .MergeCells = False    End With    Selection.Borders(xlDiagonalDown).LineStyle = xlNone    Selection.Borders(xlDiagonalUp).LineStyle = xlNone    Selection.Merge        Intersect(Selection.EntireRow, Range("M:N")).Select    With Selection        .HorizontalAlignment = xlCenter        .VerticalAlignment = xlCenter        .WrapText = False        .Orientation = 0        .AddIndent = False        .IndentLevel = 0        .ShrinkToFit = False        .ReadingOrder = xlContext        .MergeCells = False    End With    Selection.Borders(xlDiagonalDown).LineStyle = xlNone    Selection.Borders(xlDiagonalUp).LineStyle = xlNone    Selection.Merge        ActiveCell.Offset(0, -12).Select    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _        True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _        AllowFormattingRows:=True, AllowInsertingRows:=True, AllowDeletingRows:= _        True, AllowSorting:=True, AllowFiltering:=True, Password:=("2550")End Sub

Esse é o código de inserir linha que uso no botão.

Sobre os tópicos um eu já cliquei em resolvido o outro ainda não tive tempo para poder dar uma olhada, por isso ainda não respondi.

Boa tarde, possuo um código que ao clicar em uma célula (Mesclada) aparece uma inputbox, veja abaixo o código: 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)    Application.ScreenUpdating = FalseDim Selection, Resposta As IntegerDim cod As StringDim txtValor As CurrencyIf Not Intersect(Target, Range("Codigo1:Codigo2")) Is Nothing Then    Selection = Application.InputBox("Digite o código", "Código", "Número do código", Type:=1)End IfEnd Sub

"Codigo1:Codigo2", são intervalos renomeados, que seria o mesmo de "D4:D21" e "N4:N21".

Dentro desse parâmetro que ao clicar aparece a inputbox.

Ela funciona perfeitamente, o que meu problema é que tenho um botão que insere linha, e esse botão pega um intervalo dentro do parâmetro e aparece as inputbox, mas eu gostaria que fosse bloqueado essas inputbox quando eu clicasse nesse botão. O botão de inserir linha, sempre vai selecionar a linha acima da "Venda:".Segue desenho para melhor entendimento:

 

 

Desde já agradeço.

Boa tarde. Possuo um código que me retorna o caminho absoluto + nome do arquivo, segue código:

 

Sub lsSelecionarArquivo()    Dim fDlg As FileDialog    Dim lArquivo As String     'Chama o objeto passando os parâmetros    Set fDlg = Application.FileDialog(FileDialogType:=msoFileDialogOpen)    With fDlg        'Alterar esta propriedade para True permitirá a seleção de vários arquivos        .AllowMultiSelect = False         'Determina a forma de visualização dos aruqivos        .InitialView = msoFileDialogViewDetails         'Filtro de arquivos, pode ser colocado mais do que um filtro separando com ; por exemplo: "*.xls;*.xlsm"        .Filters.Add "Texto", "*.xlsm", 1         'Determina qual o drive inicial        .InitialFileName = "C:\"                'Texto da barra        .Title = "Selecionar arquivo"    End With     'Retorna o arquivo selecionado    If fDlg.Show = -1 Then        lArquivo = fDlg.SelectedItems(1)end sub

Neste caso, o lArquivo quando seleciono um arquivo por exemplo, me retorna isso: 

 

F:\ARQUIVOS LOJA\RELATORIOS LOJAS\MURIAÉ\2015\ABRIL\Relatorio Diario Muriaé - 01-04-2015.xlsm

 

Eu preciso de uma forma de separar o caminho do nome do arquivo

F:\ARQUIVOS LOJA\RELATORIOS LOJAS\MURIAÉ\2015\ABRIL\
Relatorio Diario Muriaé - 01-04-2015.xlsm 

 

para trabalhar com eles separados, teria alguma forma disso acontecer? Lembrando, o nome do caminho e do arquivo podem variar.

Desde já agradeço.

Sub CopyFolders() Dim dia As Byte   For dia = 1 To 31     If Weekday(Format(dia & "-6-2015", "dd-mm-yyyy"), 1) <> 1 And Weekday(Format(dia & "-6-2015", "dd-mm-yyyy")) <> 7 Then      FileCopy "F:\Relatorio Diario Barbacena - 2015.xlsm", "F:\ARQUIVOS LOJA\RELATORIOS LOJAS\BARBACENA\2015\JUNHO\Relatorio Diario Barbacena - " & (Format(dia, "0#")) & "-06-2015.xlsm"     End If    Next diaEnd Sub

obs. em lugar de colocar mês e ano no código e precisar alterar a cada mudança, sugiro que você coloque mês e ano em uma célula e coloque no código um comando para buscar a informação naquela célula, assim você não será obrigado a mexer no código.

 

 

 

Desculpa pela demora da resposta. Muito obrigado pela sua ajuda, atendeu perfeitamente o que precisava, em questão do mês e o ano que você deu a dica, eu já havia pensado e arrumado o meu código.

Boa noite. Possuo um código que copia uma pasta de trabalho, ela funciona normalmente, porém gostaria de criar com as datas do mês tirando o final de semana. Segue meu código que cria com a data 01 até 31.

Sub CopyFolders()Dim dia As Byte    For dia = 1 To 31FileCopy "F:\Relatorio Diario Barbacena - 2015.xlsm", "F:\ARQUIVOS LOJA\RELATORIOS LOJAS\BARBACENA\2015\JUNHO\Relatorio Diario Barbacena - " & (Format(dia, "0#")) & "-06-2015.xlsm"    Next diaEnd Sub

Neste código ele cria os arquivos Relatorio Diario Barbacena - 01-06-2015 até 31-06-2015, mas preciso eliminar as datas que seriam os finais de semana refente aquele mês.

(Esta dificuldade para se anexar um arquivo aqui no fórum ocorre constantemente devido à inexistência de informações. Será que antes de completar 200 anos no ar este fórum vai publicar orientações para se anexar arquivo...???)

 

Leo, experimente compactar o seu arquivo e depois tente anexá-lo à sua próxima mensagem. Se não conseguir, poderá upar em um site gratuitamente, veja link abaixo, e depois colocar o link aqui.

https://www.sendspace.com/

(não requer cadastro, é facinho)

 

Deu certo. Obrigado. Segue anexo com a planilha em questão.

Relatorio Diario - 2015.rar

Já consegui resolver aqui. Tive que ativar a célula onde está escrito a palavra "ENTRADA" e usar o Offset, dessa forma funciona perfeitamente o que eu buscava.

Olá, Leo.

Para facilitar a ajuda sugiro que você disponibilize uma amostra do seu arquivo com o formulário e todos os códigos instalados.

 

Osvaldo, boa tarde. Estou tentando anexar o arquivo, porém o sistema diz que eu não tenho permissão para fazer o upload deste tipo de arquivo, que seria uma planilha do excel.

Boa tarde. Estou precisando de uma grande ajuda, vou tentar ser o mais claro possível.

É o seguinte. Possuo um relatório e nesse relatório coloquei um formulário que insere a entrada e saída de material e é salvo em um determinado campo.
Veja na imagem: 

 

 

 

O formulário funciona perfeitamente, ela salva as entradas na linha 23 e as saídas na linha 24, mas o grande problema é quando essas linhas são modificadas, inserindo linha ou excluindo nas informações anteriores,ou seja, ela pode ser modificada, então gostaria de salvar sempre na linha onde está escrito "Entrada" e "Saída", independente da posição da linha.

 

Aqui está a programação a qual salva as informações da Saída:

Range("C24").Value = soma1Range("D24").Value = soma2Range("E24").Value = soma3Range("F24").Value = soma4Range("G24").Value = soma5Range("H24").Value = soma6Range("I24").Value = num25Range("J24").Value = num26Range("K24").Value = num27Range("L24").Value = num28Range("M24").Value = soma7Range("N24").Value = soma8

Desde já agradeço.

É possível q você solucionasse o seu problema melhor com a utilização de tabela dinâmica ao invés de macro p/ adicionar linha.

Quanto ao segundo problema você poderia resolver nomeando a sua tabela fonte da validação.

 

Anexei uma planilha exemplo com soluções utilizando tabelas dinâmicas, tabelas nomeadas e ferramenta p/ segmentação de dados p/ q você compreenda melhor do q estou falando.

Bom dia DJunqueira. Onde está o anexo que não encontro? E desde já agradeço a ajuda.

Bom dia!!

 

Tente assim..

Sub ZinhoVBA_1110934()    Dim Found  As Range    Set Found = Columns("J").EntireRow.Find(what:="RESTANTE", LookIn:=xlValues, Lookat:=xlWhole)    If Not Found Is Nothing Then        Found.Resize(, 2).Insert Shift:=xlDown        Application.CutCopyMode = False    End IfEnd Sub

favor adaptar!!!!!!!!!!!!

 

Att

 

Deu certo, porém quando eu clico novamente ele não copia todas as mesmas informações. Ele insere a linha, mas fica sem as fórmulas iguais as linhas anteriores. E tenho um outro problema também, na coluna A, nas celulas aparece uma lista, as quais sao digitadas nessa pequena tabela onde está sendo inserida as linhas na coluna L, e quando insiro a linha e coloco algum nome nela, não aparece na lista da coluna A.

 

Boa tarde. Preciso de uma macro para inserir no botão que aparece na imagem a seguir. Esse botão irá acresentar uma linha acima do ítem "RESTANTE" com as formatações iguais as da "L17:N:17", as quais existe suas fórmulas, mas não gostaria que fosse modificado nada na tabela ao lado.

 

Boa tarde Patropi,

é exatamente isso que precisava, agradeço muito a ajuda, acabei postando aqui por não achar o tópico sobre excel, ou eu que não procurei direito. Vou dar uma olhada no topico de excel. valeu ae.

Bom dia. Sou novo na área da programação VBA no excel e estou com uma dificuldade na hora de clicar no botão que fiz para deixar uma coluna na ordem alfabética, é uma formula simples, criada pelo gravador do vba, mas sempre que clico no botão da um erro dizendo que minha planilha é protegida por SENHA, então gostaria de configurar para que na própria macro fosse inserida o desbloqueio e o bloqueio automático com SENHA. Segue a macro e o que poderia ser feito.
 

Sub OrdemAlfabeticaData()Sheets("JANEIRO").SelectRange("B5").SelectActiveWorkbook.Worksheets("JANEIRO").ListObjects(" Tabela3568").Sort.SortFields. _ClearActiveWorkbook.Worksheets("JANEIRO").ListObjects(" Tabela3568").Sort.SortFields. _Add Key:=Range("B5"), SortOn:=xlSortOnValues, Order:=xlAscending, _DataOption:=xlSortNormalWith ActiveWorkbook.Worksheets("JANEIRO").ListObjects(" Tabela3568").Sort.Header = xlYes.MatchCase = False.Orientation = xlTopToBottom.SortMethod = xlPinYin.ApplyEnd WithEnd Sub

Desde já agradeço.