Copie e insira automaticamente uma linha sob a última célula preenchida

Question

Eu tenho lutado com esse problema por um tempo agora, e vou tentar explicá-lo da melhor maneira possível.

Eu tenho uma tabela ativa que está constantemente aumentando em números de linha. Cada linha tem algumas propriedades e células ocultas que devem estar lá. Então, meu problema é este:

Quando chegar a um número de linha ex.100 e a tabela estiver cheia, gostaria de inserir uma nova linha abaixo daquela com as mesmas propriedades que a anterior.

Consegui encontrar alguns códigos na internet e mesclá-los em um código funcional, mas há muitos problemas com ele. Aqui está o código:

Private Sub Workbook_Open()

Sub BlankLine()

    Dim Col As Variant
    Dim BlankRows As Long
    Dim LastRow As Long
    Dim R As Long
    Dim StartRow As Long

        Col = "C"
        StartRow = 123
        BlankRows = 1

            LastRow = Cells(Rows.Count, Col).End(xlUp).Row

            Application.ScreenUpdating = False

            With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If IsEmpty(.Cells(R, Col)) = False Then
.Cells(R + 1, Col).EntireRow.Copy
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
Range("A1").ClearOutline
End If
Next R
End With
Application.ScreenUpdating = True
End Sub

Então, aqui está o que acontece: Quando você abre o Excel, ele pesquisa imediatamente por linhas após número de linha 123 com qualquer coisa na célula C e copia a seguinte linha vazia após a atual. O problema aqui é que toda vez que abro o excel ele faz isso e faz cópias de cópias de cópias.

Como eu preciso que isso aconteça: Quando você abrir o Excel, o código estará ativo e quando você preencher o número de linha 124 para copiar a linha 125 e inseri-la na linha 124 e terminar com a linha 124. Agora, mova o código para o número de linha 125 e quando essa linha tiver dados na célula C para copiar a linha 126 e movê-la abaixo de 125 e depois parar e assim por diante ...

A ideia é que a tabela aumente ativamente nas linhas e copie os dados para que você não precise fazer isso manualmente quando estiver preenchida.

Desculpe pela longa explicação, espero que haja uma solução.

Obrigado antecipadamente.

    

Answer 1

Você precisa mover o código do evento Workbook_Open() no evento Worksheet_Change()

Certifique-se também de usar Option Explicit em todos os módulos

Coloque isso no módulo Folha VBA. Ele será acionado somente quando as células na coluna C forem atualizadas

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge = 1 Then   'Check that only 1 cell is being edited
        If Len(Target) > 0 Then     'Make sure the cell is not empty
            With Target
                If .Row > 1 And .Column = 3 Then    'Exclude Header row, and act on col 3
                    OptimizeApp True
                    MovePropRow Target
                    OptimizeApp False
                End If
            End With
        End If
    End If
End Sub

Private Sub MovePropRow(ByVal Target As Range)
    Dim ws As Worksheet:    Set ws = Target.Parent
    Dim lr As Long:         lr = Target.Row
    Dim lrProp As Long:     lrProp = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    If lrProp = lr Then
        ws.Range(ws.Cells(lr, "D"), ws.Cells(lr, "I")).Copy
        ws.Cells(lr + 1, "D").PasteSpecial xlPasteAll
        ws.Range(ws.Cells(lr, "D"), ws.Cells(lr, "I")).Clear
        Target.Select
    End If
End Sub

Private Sub OptimizeApp(ByVal speedUp As Boolean)
    Application.Calculation = IIf(speedUp, xlCalculationManual, xlCalculationAutomatic)
    Application.ScreenUpdating = Not speedUp
    Application.DisplayAlerts = Not speedUp
    Application.EnableEvents = Not speedUp
End Sub

Teste Sheet3 - Before

TesteSheet3-After(typing"x" in Cell "C10")