CODEWITHSUNDEEP
vbaexcelcells
chiv
chiv

Reputation: 15

Add amount of blank rows based on cell value

As the majority of those seeking aid here I am new to VBA, but I figured there is no way to solve my problem with conventional formulas hence the explanation:

I have several sets of materiel codes in col. A sorted from smallest to largest, their corresponding data in columns B to Y. What I need is add an amount of blank rows below every set of codes equalling the corresponding value in col. Z, below is an example of "before"

 - Col. A   ----  Col. Z
 - 65504927 - 3
 - 65504927 - 3
 - 65504927 - 3
 - 65505044 - 1
 - 65505044 - 1
 - 65505044 - 1
 - 65505151 - 0
 - 65505151 - 0
 - 65505297 - 2
 - 65505297 - 2

and After - 

- Col. A   ----  Col. Z
- 65504927 - 3
- 65504927 - 3
- 65504927 - 3
- "blank row"
- "blank row"
- "blank row"
- 65505044 - 1
- 65505044 - 1
- 65505044 - 1
- "blank row"
- 65505151 - 0
- 65505151 - 0
- 65505297 - 2
- 65505297 - 2
- "blank row"
- "blank row"

I found a suggestion for a similar problem in one of the posts here (it adds a single row after every set of data) but I can't yet grasp VB architecture enough to make alterations, so I'd greatly appreciate your help, thanks in advance.

Upvotes: 1

Views: 126

Answers (3)

chiv
chiv

Reputation: 15

Thank you all very much for your help, you've got an awesome and helpful community here!

Special thanks to @sgp667, this worked like a charm:

Sub add_blank_rows()
Dim Awsh      As Worksheet
Dim ARow      As Range
Dim AColumn   As Range
Dim UsedRange As Range
Dim to_insert As Integer
Dim count     As Integer

Set Awsh = ActiveSheet
Set UsedRange = Awsh.UsedRange
Set AColumn = Range(Cells(1, 26), Cells(UsedRange.End(xlDown).Row, 26))

For Each ARow In AColumn
    If Not ARow.Offset(1, 0) = ARow And _
       IsNumeric(ARow.Offset(1, 0)) And _
       IsNumeric(ARow) Then

        to_insert = ARow

        For count = 1 To to_insert
            ARow.Offset(1).EntireRow.Insert
        Next count
    End If
Next ARow

End Sub

Cheers!

Upvotes: 0

Jeanno
Jeanno

Reputation: 2859

You first need to determine which is the last row containing a unique value because after this row is when blanks are inserted. I have added an extra column "C" to indicate whether the row is the last one. 

Sub AssignLast()
    Dim i As Long

    For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
        If i = 1 Then
            If Range("A" & i).Value <> Range("A" & i + 1).Value Then
                Range("C" & i).Value = 1
            End If
        Else
            If Range("A" & i).Value = Range("A" & i - 1).Value And _
                Range("A" & i).Value <> Range("A" & i + 1).Value Then
                    Range("C" & i).Value = 1
            End If
        End If
    Next i
End Sub

Sub InsertBlankRows()
    Dim i As Long

    For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
        If Range("C" & i).Value = 1 Then
            Rows(i + 1 & ":" & i + Range("B" & i).Value).Insert Shift:=xlDown
        End If
    Next i
End Sub

Upvotes: 1

sgp667
sgp667

Reputation: 1875

Following worked for me:

Sub add_blank_rows()
    Dim Awsh      As Worksheet
    Dim ARow      As Range
    Dim AColumn   As Range
    Dim UsedRange As Range
    Dim to_insert As Integer
    Dim count     As Integer

    Set Awsh = ActiveSheet
    Set UsedRange = Awsh.UsedRange
    Set AColumn = Range(Cells(1, 26), Cells(UsedRange.End(xlDown).Row, 26))

    For Each ARow In AColumn
        If Not ARow.Offset(1, 0) = ARow And _
           IsNumeric(ARow.Offset(1, 0)) And _
           IsNumeric(ARow) Then

            to_insert = ARow

            For count = 1 To to_insert
                ARow.Offset(1).EntireRow.Insert
            Next count
        End If
    Next ARow
End Sub

Upvotes: 1

Related Questions