none
Macro que insere linha no final de uma TABELA RRS feed

  • Pergunta

  • Amigos me deparei com um problema, estou tentando criar uma macro que insere uma nova linha, dentro de uma tabela do Excel, sendo que essa macro é executada por uma palavra chave que digito em qualquer célula da coluna "B", e a função dela é inserir uma nova linha, mas sempre abaixo da célula que digitei a palavra chave. O problema e que toda vez que a tabela chega ao final, na última linha, quando eu executo a macro para inserir uma nova linha, na tabela, ela não é inserida na forma correta, pois a linha criada fica fora dos limites da tabela, me obrigando a clicar com o mause no canto inferior da tabela, segurar clicado e arrastar até a linha criada fazer parte da tabela. Alguém conhece algum código VBA que possa me ajudar. Obrigado.

    quinta-feira, 23 de outubro de 2014 23:30

Respostas

  • Prezado,

    O objeto do VBA relacionado à tabela chama-se "ListObject" e possui diversos métodos e propriedades muito interessantes.

    Alguns pontos quanto ao código abaixo:

    • Parti da premissa que a coluna 2 pertence à tabela. Adotei esta premissa pois se a tabela estivesse contida apenas na primeira coluna, ela se "auto-expandiria" com a digitação de "SIMM" na coluna 2.
    • Foquei na solução de inserção da linha e não me preocupei com a condição "NÃOO", as seleções e formatações.

    Abaixo segue código:

    Private Sub Worksheet_Change(ByVal Target As Range)
        Dim TargetRowInTable As Integer
        Dim myTable As ListObject
        
        'condições de saída
        If TypeName(Target) <> "Range" Then Exit Sub
        If Target.Cells.Count > 1 Then Exit Sub
        If Target.Column <> 2 Then Exit Sub
        If Target.ListObject Is Nothing Then Exit Sub   'célula alterada tem que estar dentro da tabela
        
        Application.EnableEvents = False
        Set myTable = ListObjects("Tabela1")
        If Target.Value = "SIMM" Then
            TargetRowInTable = Target.Row - myTable.HeaderRowRange.Row
            myTable.ListRows.Add TargetRowInTable + 1, False
        End If
        Application.EnableEvents = True
    End Sub

    Espero que eu tenha entendido sua necessidade e que o código resolva o seu problema. Em caso afirmativo, peço a gentileza de marcar este post como sendo a resposta à sua dúvida.

    Abraços,


    Marcelo Nogueira | CEO | Clarian Solutions | www.clarian.com.br | Excel Development & Trainning

    quarta-feira, 19 de novembro de 2014 03:53

Todas as Respostas

  • Olá, você poderia postar o código que você está usando?

    Rafael Kamimura

    sexta-feira, 24 de outubro de 2014 12:24
  • Sem muita enrolação:

    Private Sub Worksheet_Change(ByVal Target As Range)
      If TypeName(Target) <> "Range" Then Exit Sub
      If Target.Cells.CountLarge > 1 Then Exit Sub
      If Target.Column <> 3 Then Exit Sub
      
      Application.EnableEvents = False
      Rows(Target.Row + 1).Insert
      Cells(Target.Row + 1, "C") = "x"
      Rows(Target.Row + 1).ClearContents
      Application.EnableEvents = True
    End Sub
    


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sexta-feira, 24 de outubro de 2014 21:47
    Moderador
  • Boa noite amigos, conforme descrito em minha outra mensagem, preciso criar uma macro que é executada por uma palavra chave ("SIMM") que toda vez que for digitada em uma determinada célula irá executar a macro. A função da macro é inserir uma nova linha em uma tabela (da aba "INSERIR" ==> "TABELA") que eu criei. Eu consegui criar um código que inseri uma nova linha, o problema é que ele tem um erro, quando chega ao final da tabela, na última linha da mesma, ele inseri uma nova linha mas essa fica totalmente fora dos limites da tabela, me obrigando a  clicar e segura na lateral inferior direita da tabela e arrastar seu limites para anexar a linha que foi criada.

    Esse é meu código que não funciona corretamente quando o executo na última linda da tabela:

    Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Cells.Count > 1 Then Exit Sub
    
     If Target.Column = (2) And Target.Value = ("SIMM") Then
       ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Application.Goto Reference:="R3C2"
        
     ElseIf Target.Column = (2) And Target.Value = ("NÃOO") Then
        ActiveCell.Offset(1, 0).Range("A1").Select
        With Selection.Font
            .Name = "Calibri"
            .Size = 18
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .ThemeFont = xlThemeFontMinor
        End With
        Selection.Font.Bold = True
        Selection.Font.Underline = xlUnderlineStyleSingle
        ActiveCell.Offset(0, -1).Range("A1:O1").Select
    
     Else: Exit Sub
     End If
    
    End Sub

    Eu substitui o código acima pelo que o amigo Felipe Costa Gualberto postou para me ajudar, mas por algum motivo ele não executou quando fiz a substituição. Com a alteração ele ficou assim:

    Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Cells.Count > 1 Then Exit Sub
    
     If Target.Column = (2) And Target.Value = ("SIMM") Then
        If TypeName(Target) <> "Range" Then Exit Sub
        If Target.Cells.CountLarge > 1 Then Exit Sub
        If Target.Column <> 3 Then Exit Sub
    
        Application.EnableEvents = False
        Rows(Target.Row + 1).Insert
        Cells(Target.Row + 1, "C") = "x"
        Rows(Target.Row + 1).ClearContents
        Application.EnableEvents = True
    
     ElseIf Target.Column = (2) And Target.Value = ("NÃOO") Then
        ActiveCell.Offset(1, 0).Range("A1").Select
        With Selection.Font
            .Name = "Calibri"
            .Size = 18
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .ThemeFont = xlThemeFontMinor
        End With
        Selection.Font.Bold = True
        Selection.Font.Underline = xlUnderlineStyleSingle
        ActiveCell.Offset(0, -1).Range("A1:O1").Select
    
     Else: Exit Sub
     End If
    
    End Sub
    

    Desculpem-me pelo trabalho, mas se puderem me ajudar a fazer esse código funcionar fico grato. Para facilitar vou postar um link com um exemplo simples só para efeito de visualização da planilha que estou a criar.

    http://www.4shared.com/file/HnxA8kEIba/exemplo.html

    Sem mais delongas, agradecido.

     
    terça-feira, 28 de outubro de 2014 22:03
  • Alguém responde minha pergunta acima por favor, já tentei muitas soluções e não dei conta de resolver o problema.

    Onésio.

    terça-feira, 4 de novembro de 2014 16:25
  • Prezado,

    O objeto do VBA relacionado à tabela chama-se "ListObject" e possui diversos métodos e propriedades muito interessantes.

    Alguns pontos quanto ao código abaixo:

    • Parti da premissa que a coluna 2 pertence à tabela. Adotei esta premissa pois se a tabela estivesse contida apenas na primeira coluna, ela se "auto-expandiria" com a digitação de "SIMM" na coluna 2.
    • Foquei na solução de inserção da linha e não me preocupei com a condição "NÃOO", as seleções e formatações.

    Abaixo segue código:

    Private Sub Worksheet_Change(ByVal Target As Range)
        Dim TargetRowInTable As Integer
        Dim myTable As ListObject
        
        'condições de saída
        If TypeName(Target) <> "Range" Then Exit Sub
        If Target.Cells.Count > 1 Then Exit Sub
        If Target.Column <> 2 Then Exit Sub
        If Target.ListObject Is Nothing Then Exit Sub   'célula alterada tem que estar dentro da tabela
        
        Application.EnableEvents = False
        Set myTable = ListObjects("Tabela1")
        If Target.Value = "SIMM" Then
            TargetRowInTable = Target.Row - myTable.HeaderRowRange.Row
            myTable.ListRows.Add TargetRowInTable + 1, False
        End If
        Application.EnableEvents = True
    End Sub

    Espero que eu tenha entendido sua necessidade e que o código resolva o seu problema. Em caso afirmativo, peço a gentileza de marcar este post como sendo a resposta à sua dúvida.

    Abraços,


    Marcelo Nogueira | CEO | Clarian Solutions | www.clarian.com.br | Excel Development & Trainning

    quarta-feira, 19 de novembro de 2014 03:53