Add blank Excel line using VBA

Asked

Viewed 6,025 times

1

I have a spreadsheet with 10k lines, in this format (example):

3004977 \{DOWN} \{TAB 9}    REMESSAS    \%S 18082017    \{TAB}  2   \%D \^ S

3004972 \{DOWN} \{TAB 9}    REMESSAS    \%S 18082017    \{TAB}  3   \%D 
3004972 \{DOWN} \{TAB 9}    REMESSAS    \%S 18082017    \{TAB}  2   \%D 
3004972 \{DOWN} \{TAB 9}    REMESSAS    \%S 18082017    \{TAB}  2   \%D 
3004972 \{DOWN} \{TAB 9}    REMESSAS    \%S 18082017    \{TAB}  2   \%D 
3004972 \{DOWN} \{TAB 9}    REMESSAS    \%S 18082017    \{TAB}  1   \%D \^ S

3004967 \{DOWN} \{TAB 9}    REMESSAS    \%S 18082017    \{TAB}  110 \%D \^ S

With each change in column A there is a blank line. But I need to insert 3 more, in all. With the code below, which I found in Soen, he only adds in the first:

Sub AddBlankRows()
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Range("a1")

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub

Any suggestions?

vba

  • From what I understand will always have a line between the data and you need three lines? If this is it I believe that macro below will help you!

2 answers

1


See if this way suits you:

Sub AdicionaLinhaBranco()

Dim COLUNA_VERIFICAR As String
Dim ULTIMA_LINHA As Integer
Dim QTD_LINHAS As Integer
Dim i As Integer

Application.ScreenUpdating = False

COLUNA_VERIFICAR = "A"
QTD_LINHAS = 2
ULTIMA_LINHA =     ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row

Range(COLUNA_VERIFICAR & "1").Select

Do While ActiveCell.Row < ULTIMA_LINHA

    If ActiveCell.Offset(1).Value <> "" Then
        ActiveCell.Offset(1).Select
    Else
        ActiveCell.Offset(1).Select
        For i = 1 To QTD_LINHAS
            ActiveCell.EntireRow.Insert Shift:=xlDown
        Next i
        ActiveCell.Offset(QTD_LINHAS + 1).Select
        ULTIMA_LINHA = ULTIMA_LINHA + QTD_LINHAS
    End If
Loop

End Sub

Good luck and success!

0

With a few minor changes I managed...

Sub AddBlankRows()
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Range("a1")

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then

    Cells(iRow + 1, iCol).EntireRow.Insert shift:=xlDown

    Cells(iRow + 1, iCol).EntireRow.Insert shift:=xlDown

    Cells(iRow + 1, iCol).EntireRow.Insert shift:=xlDown

    iRow = iRow + 4

Else
    iRow = iRow + 1

End If

'
Loop While Not Cells(iRow, iCol).Text = ""

'
End Sub

Browser other questions tagged vba

You are not signed in. Login or sign up in order to post.