INSERT ROW WITH SPECIFIS TEXT IN A COLUMN

[xenios]

Hi All!

How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F.

If I record the macro it gives me the following result.

Sub INSERT()
'
' INSERT Macro
'

'
    Rows("2:2").Select
    Selection.INSERT Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "JUICE"
    Range("A2:G2").Select
    Range("G2").Activate
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
    End With
    Selection.Copy
    ActiveWindow.ScrollRow = 3
    ActiveWindow.ScrollRow = 7
    ActiveWindow.ScrollRow = 9
    ActiveWindow.ScrollRow = 11
    ActiveWindow.ScrollRow = 12
    ActiveWindow.ScrollRow = 13
    ActiveWindow.ScrollRow = 14
    ActiveWindow.ScrollRow = 16
    ActiveWindow.ScrollRow = 19
    ActiveWindow.ScrollRow = 21
    ActiveWindow.ScrollRow = 22
    ActiveWindow.ScrollRow = 23
    ActiveWindow.ScrollRow = 24
    ActiveWindow.ScrollRow = 25
    ActiveWindow.ScrollRow = 26
    ActiveWindow.ScrollRow = 27
    ActiveWindow.ScrollRow = 28
    ActiveWindow.ScrollRow = 29
    ActiveWindow.ScrollRow = 30
    ActiveWindow.ScrollRow = 31
    ActiveWindow.ScrollRow = 32
    ActiveWindow.ScrollRow = 33
    ActiveWindow.ScrollRow = 34
    ActiveWindow.ScrollRow = 35
    ActiveWindow.ScrollRow = 36
    ActiveWindow.ScrollRow = 37
    ActiveWindow.ScrollRow = 38
    ActiveWindow.ScrollRow = 39
    ActiveWindow.ScrollRow = 40
    ActiveWindow.ScrollRow = 41
    ActiveWindow.ScrollRow = 42
    ActiveWindow.ScrollRow = 43
    ActiveWindow.ScrollRow = 44
    ActiveWindow.ScrollRow = 45
    ActiveWindow.ScrollRow = 46
    ActiveWindow.ScrollRow = 47
    ActiveWindow.ScrollRow = 48
    ActiveWindow.ScrollRow = 49
    ActiveWindow.ScrollRow = 50
    ActiveWindow.ScrollRow = 51
    ActiveWindow.ScrollRow = 52
    ActiveWindow.ScrollRow = 53
    ActiveWindow.ScrollRow = 54
    ActiveWindow.ScrollRow = 55
    ActiveWindow.ScrollRow = 56
    ActiveWindow.ScrollRow = 57
    ActiveWindow.ScrollRow = 58
    ActiveWindow.ScrollRow = 62
    ActiveWindow.ScrollRow = 66
    ActiveWindow.ScrollRow = 68
    ActiveWindow.ScrollRow = 69
    ActiveWindow.ScrollRow = 70
    ActiveWindow.ScrollRow = 71
    ActiveWindow.ScrollRow = 72
    Rows("82:82").Select
    Selection.INSERT Shift:=xlDown
    Range("A82").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "MELON"
    Range("A82:G82").Select
    Range("G82").Activate
    Selection.Copy
    ActiveWindow.ScrollRow = 73
    ActiveWindow.ScrollRow = 74
    ActiveWindow.ScrollRow = 77
    ActiveWindow.ScrollRow = 79
    ActiveWindow.ScrollRow = 80
    ActiveWindow.ScrollRow = 82
    ActiveWindow.ScrollRow = 83
    ActiveWindow.ScrollRow = 84
    ActiveWindow.ScrollRow = 85
    ActiveWindow.ScrollRow = 87
    ActiveWindow.ScrollRow = 88
    ActiveWindow.ScrollRow = 89
    ActiveWindow.ScrollRow = 90
    ActiveWindow.ScrollRow = 91
    ActiveWindow.ScrollRow = 92
    ActiveWindow.ScrollRow = 93
    ActiveWindow.ScrollRow = 94
    ActiveWindow.ScrollRow = 95
    ActiveWindow.ScrollRow = 96
    ActiveWindow.ScrollRow = 97
    ActiveWindow.ScrollRow = 99
    ActiveWindow.ScrollRow = 101
    ActiveWindow.ScrollRow = 102
    ActiveWindow.ScrollRow = 103
    ActiveWindow.ScrollRow = 104
    ActiveWindow.ScrollRow = 105
    ActiveWindow.ScrollRow = 106
    ActiveWindow.ScrollRow = 107
    ActiveWindow.ScrollRow = 108
    ActiveWindow.ScrollRow = 109
    ActiveWindow.ScrollRow = 110
    ActiveWindow.ScrollRow = 112
    ActiveWindow.ScrollRow = 114
    ActiveWindow.ScrollRow = 117
    ActiveWindow.ScrollRow = 118
    ActiveWindow.ScrollRow = 119
    ActiveWindow.ScrollRow = 120
    ActiveWindow.ScrollRow = 121
    ActiveWindow.ScrollRow = 122
    ActiveWindow.ScrollRow = 123
    ActiveWindow.ScrollRow = 124
    Rows("132:132").Select
    Selection.INSERT Shift:=xlDown
    Range("A132").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "APPLE"
    Range("A132:G132").Select
    Range("G132").Activate
    Selection.Copy
    ActiveWindow.ScrollRow = 125
    ActiveWindow.ScrollRow = 127
    ActiveWindow.ScrollRow = 129
    ActiveWindow.ScrollRow = 132
    ActiveWindow.ScrollRow = 140
    ActiveWindow.ScrollRow = 143
    ActiveWindow.ScrollRow = 145
    ActiveWindow.ScrollRow = 147
    ActiveWindow.ScrollRow = 148
    ActiveWindow.ScrollRow = 149
    ActiveWindow.ScrollRow = 150
    ActiveWindow.ScrollRow = 151
    ActiveWindow.ScrollRow = 152
    ActiveWindow.ScrollRow = 153
    ActiveWindow.ScrollRow = 154
    ActiveWindow.ScrollRow = 157
    ActiveWindow.ScrollRow = 160
    ActiveWindow.ScrollRow = 162
    ActiveWindow.ScrollRow = 163
    ActiveWindow.ScrollRow = 164
    ActiveWindow.ScrollRow = 165
    ActiveWindow.ScrollRow = 166
    ActiveWindow.ScrollRow = 167
    ActiveWindow.ScrollRow = 168
    ActiveWindow.ScrollRow = 169
    ActiveWindow.ScrollRow = 170
    ActiveWindow.ScrollRow = 171
    Rows("183:183").Select
    Selection.INSERT Shift:=xlDown
    Range("A183").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "LIME"
    Range("B184").Select
End Sub

 

[My Aswer Is This]

Still cannot understand what you want. Hoping someone else here will be able to help you

 

[xenios]

Still cannot understand what you want. Hoping someone else here will be able to help you

Thank you for the try.
Here are the last example for understanding, may be will help
The initial and the result needed.

 

[My Aswer Is This]

In your initial image you have Alpha twice.
But in your result page you only showed one row inserted for alpha
Is that a mistake? if not why?

 

[mohadin]

Hi xenios
Would you try this

Sub test()
    Dim lr, i, l
    Dim x, a, y
    Dim sh
    ReDim a(1 To 100)
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    lr = sh.Cells(Rows.Count, 6).End(xlUp).Row
    With CreateObject("scripting.dictionary")
        For i = 2 To lr
            If Not .exists(Cells(i, 6).Value) Then
                .Add Cells(i, 6).Value, Cells(i, 6).Address
            End If
        Next
        y = .items
       For i = UBound(y) To 0 Step -1
       Range(y(i)).EntireRow.Insert
        Range(y(i)) = Range(y(i)).Offset(1)
        Range(y(i)).Offset(, -5).Resize(, 7).Merge
        Range(y(i)).HorizontalAlignment = xlCenter
       Next
    End With
    Application.ScreenUpdating = True
End Sub

 

[mohadin]

Or Maybe

Sub test()
    Dim lr, i, l
    Dim x, a, y
    Dim sh
    ReDim a(1 To 100)
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    lr = sh.Cells(Rows.Count, 6).End(xlUp).Row
    With CreateObject("scripting.dictionary")
        For i = 2 To lr
            If Not .exists(Cells(i, 6).Value) Then
                .Add Cells(i, 6).Value, Cells(i, 6).Address
            End If
        Next
        For i = .Count - 1 To 0 Step -1
            Range(.Items()(i)).EntireRow.Insert
            Range(.Items()(i)) = Range(y(i)).Offset(1)
            Range(.Items()(i)).Offset(, -5).Resize(, 7).Merge
            Range(.Items()(i)).HorizontalAlignment = xlCenter
        Next
    End With
    Application.ScreenUpdating = True
End Sub

 

[xenios]

Hi xenios
Would you try this

Sub test()
    Dim lr, i, l
    Dim x, a, y
    Dim sh
    ReDim a(1 To 100)
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    lr = sh.Cells(Rows.Count, 6).End(xlUp).Row
    With CreateObject("scripting.dictionary")
        For i = 2 To lr
            If Not .exists(Cells(i, 6).Value) Then
                .Add Cells(i, 6).Value, Cells(i, 6).Address
            End If
        Next
        y = .items
       For i = UBound(y) To 0 Step -1
       Range(y(i)).EntireRow.Insert
        Range(y(i)) = Range(y(i)).Offset(1)
        Range(y(i)).Offset(, -5).Resize(, 7).Merge
        Range(y(i)).HorizontalAlignment = xlCenter
       Next
    End With
    Application.ScreenUpdating = True
End Sub

Thank you. This one works. But makes grey only the 1st new row. If possible for the rest would be great and if text can be transformed to All caps, would be great also.

 

[xenios]

In your initial image you have Alpha twice.
But in your result page you only showed one row inserted for alpha
Is that a mistake? if not why?

 

[xenios]

In your initial image you have Alpha twice.
But in your result page you only showed one row inserted for alpha
Is that a mistake? if not why?

Alpa, cat, dog, .. can be up to 100 times in column F, and the row up on them is only once.
Can be
Alpha
Alpha
Cat
Cat
Cat
Dog
Dog

 

[xenios]

Or Maybe

Sub test()
    Dim lr, i, l
    Dim x, a, y
    Dim sh
    ReDim a(1 To 100)
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    lr = sh.Cells(Rows.Count, 6).End(xlUp).Row
    With CreateObject("scripting.dictionary")
        For i = 2 To lr
            If Not .exists(Cells(i, 6).Value) Then
                .Add Cells(i, 6).Value, Cells(i, 6).Address
            End If
        Next
        For i = .Count - 1 To 0 Step -1
            Range(.Items()(i)).EntireRow.Insert
            Range(.Items()(i)) = Range(y(i)).Offset(1)
            Range(.Items()(i)).Offset(, -5).Resize(, 7).Merge
            Range(.Items()(i)).HorizontalAlignment = xlCenter
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Here is error 13, pic attached

 

[mohadin]

OOOPs
Sorry
Try

Sub test()
    Dim lr, i, l
    Dim x, a, y
    Dim sh
    ReDim a(1 To 100)
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    lr = sh.Cells(Rows.Count, 6).End(xlUp).Row
    With CreateObject("scripting.dictionary")
        For i = 2 To lr
            If Not .exists(Cells(i, 6).Value) Then
                .Add Cells(i, 6).Value, Cells(i, 6).Address
            End If
        Next
        For i = .Count - 1 To 0 Step -1
            Range(.Items()(i)).EntireRow.Insert
            Range(.Items()(i)) = Range(.Items()(i)).Offset(1)
            Range(.Items()(i)).Offset(, -5).Resize(, 7).Merge
            Range(.Items()(i)).HorizontalAlignment = xlCenter
        Next
    End With
    Application.ScreenUpdating = True
End Sub