CODEWITHSUNDEEP
vba
Rods2292
Rods2292

Reputation: 675

Insert a row after a specific text - VBA

I want to insert a row in a excel spreadsheet after a specific text is found is a column. The text appears N times and the new row need to be inserted after the last time the text appears.

An example of what I have

ColumnA
TextA
TextA
TextA
TextA
TextB
TextB
TextB
TextB
TextC
TextC
TextC
TextC

I need to insert a new row after the last time TextA, TextB and TextC appear, each time I execute the macro.

Is there a way to find the maximum number of times a given text appears in a column? In that way it will be possible to do what I want.

EDIT:

I have tried to count the number of times each text appears and assign this value to a variable:

Sub count()
Dim A As Integer
A = Application.WorksheetFunction.CountIf(Range("B:B"), "TextA")

Dim B As Integer
B = Application.WorksheetFunction.CountIf(Range("B:B"), "TextB")

Dim C As Integer
C = Application.WorksheetFunction.CountIf(Range("B:B"), "TextC")
End Sub

After that I tried to insert a new row 

Sub insert_row ()
    Rows("4+A:4+A").Select 'The number 4 is the first row `TextA` appears. So 4+A where I need to insert my new row.
    Selection.Insert Shift:=xlDown
End Sub

With this code I have to problems

1 - A have much more than just TextA, TextB and TextC texts to find. Actually I have 30 different texts in the column.

2 - Sub insert_row () does not work.

Upvotes: 0

Views: 2430

Answers (2)

Miguel
Miguel

Reputation: 2079

Just my two cents, if performance is of any value to you.

The following code requires that you go into the VBE's Tools ► References and add Microsoft Scripting Runtime. This holds the library definitions for a Scripting.Dictionary. However, if you use CreateObject("Scripting.Dictionary"), you do not require the library reference.

enter image description here

with this code you use a scripting dictionary to find the distinct values in column A then you find the last time that value was used and insert a row right below.

Sub findlastItem()

Dim unique As Object
Dim firstcol As Variant

Set unique = CreateObject("Scripting.Dictionary")
 
With Worksheets("sheet1")
 
 firstcol = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp)).Value2
 
 For v = LBound(firstcol, 1) To UBound(firstcol, 1)
 If Not unique.Exists(firstcol(v, 1)) Then _
                unique.Add Key:=firstcol(v, 1), Item:=vbNullString
      Next v
  End With
 
  For Each myitem In unique
     findAndInsertRow myitem
  Next

 End Sub


Sub findAndInsertRow(findwhat As Variant)

    Dim FindString As String
    Dim Rng As Range
    Dim LastRange As Range
    
    listOfValues = Array(findwhat)

    If Trim(findwhat) <> "" Then
        With Sheets("Sheet1").Range("A:A")

                Set Rng = .Find(What:=listOfValues(i), _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False)
                If Not Rng Is Nothing Then
                    Rng.Offset(1, 0).Insert
                 End If
            
        End With
    End If

Upvotes: 1

BRCoder
BRCoder

Reputation: 28

This loops through the cells and adds a row each time a cell is not equal to the cell below it and the cell is not blank. 

 Sub Insert()
  Dim LastRow As Long
  Dim Cell As Range

Application.ScreenUpdating = False


    LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(-4162).Row

    For Each Cell In Sheets("Sheet1").Range("A1:A" & LastRow)
        If Cell.Value <> Cell.Offset(1, 0) Then
            If Cell.Value <> "" Then
                Sheets("Sheet1").Rows(Cell.Row + 1).Insert
            End If
        End If
    Next Cell

Application.ScreenUpdating = True


End Sub

Upvotes: 0

Related Questions