INSERT ROW WITH SPECIFIS TEXT IN A COLUMN

xenios

Board Regular
Joined
Sep 4, 2020
Messages
88
Office Version
  1. 2016
Platform
  1. Windows
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.
VBA Code:
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
 

Attachments

  • insert.png
    insert.png
    176.5 KB · Views: 13

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
781
Office Version
  1. 2013
Platform
  1. Windows
Or rather this the final code hope It's ok with you
VBA Code:
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)) = UCase(Range(.Items()(i)).Offset(1))
            Range(.Items()(i)).Interior.ColorIndex = 16
            Range(.Items()(i)).Offset(, -5).Resize(, 7).Merge
            Range(.Items()(i)).HorizontalAlignment = xlCenter
        Next
    End With
    Application.ScreenUpdating = True
End Sub
 
Solution

Some videos you may like

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

Dossfm0q

Active Member
Joined
Mar 9, 2009
Messages
483
Office Version
  1. 2019
Platform
  1. Windows
Hi
What about

VBA Code:
Sub INSERT_ROW_WITH_SPECIFIS_TEXT_IN_A_COLUMN()

Dim WB As Workbook: Set WB = ThisWorkbook
Dim WS As Worksheet: Set WS = WB.Worksheets(1) '<<<<<< Change name of sheet
Dim N As Long

Dim ClCnt As Long: ClCnt = 10 '<<<<<< Change  Columns No.

Dim ListRange As Range: Set ListRange = WS.Range("F1:F20")
Dim Rng As Range
Dim Rw As Long: Rw = ListRange.Row
Dim Cl As Long: Cl = ListRange.Column
Dim LSTRW As Long: LSTRW = WS.Cells(WS.Rows.Count, Cl).End(xlUp).Row
Dim SrtRng As Range: Set SrtRng = WS.Cells(Rw, Cl).Resize(LSTRW, 1)
'First sort range
With WS
    WS.Sort.SortFields.Clear
    WS.Sort.SortFields.Add2 Key:=SrtRng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With WS.Sort
        .SetRange SrtRng
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With

    ' Orgnize Range
    
    Columns(Cl - 3).Clear
    N = 0
    For Each Rng In SrtRng
    N = N + 1
        If Rng.Row = 1 Then
            With Rng
            
            .INSERT Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    
                    
                    
                    C = (.Column - 4) * -1 ' Column 3
                    With WS.Cells(.Row, .Column - 3)
                        With .Offset(0, C).Resize(1, ClCnt)
                            For b = 7 To 12
                                With .Borders(b)
                                    .LineStyle = xlContinuous
                                    .Color = RGB(0, 0, 0)
                                    .TintAndShade = 0
                                    .Weight = xlThin
                                End With
                            Next
                          
                        End With
                        
                    End With
                    
                    With WS.Cells(.Row - 1, .Column - 3)
                    .Value = Rng.Value
                        With .Offset(0, C).Resize(1, ClCnt)
                        
                            With .Interior
                                .Pattern = xlSolid
                                .Color = RGB(166, 166, 166)
                            End With
                        End With
                    End With
                    
            End With
        
        Else
        
            With Rng
            
                If Rng.Value <> WS.Cells(.Row - 1, .Column).Value And WS.Cells(.Row - 1, .Column).Value <> "" And WS.Cells(.Row + 1, .Column).Value <> "" Then
                  '  N = 0
                    .INSERT Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    With WS.Cells(.Row - 1, .Column - 3)
                    .Value = Rng.Value
                        With .Offset(0, -2).Resize(1, ClCnt)
                            With .Interior
                                .Pattern = xlSolid
                                .Color = RGB(166, 166, 166)
                            End With
                            
                            
                        End With
                    End With
                Else
                End If
                
              
                        C = (.Column - 1) * -1 ' Column 1
                        With .Offset(0, C).Resize(1, ClCnt)
                            
                            With .Interior
                                .Pattern = xlNone
                                .TintAndShade = 0
                                .PatternTintAndShade = 0
                            End With
                            For b = 7 To 12
                            .Borders(b).LineStyle = xlNone
                            Next
                            For b = 7 To 12
                                With .Borders(b)
                                    .LineStyle = xlContinuous
                                    .Color = RGB(0, 0, 0)
                                    .TintAndShade = 0
                                    .Weight = xlThin
                                End With
                            Next
                            
                            If Rng.Value <> "" And N Mod 2 = 0 Then
                            With .Interior
                                .Pattern = xlSolid
                                .Color = RGB(240, 240, 240)
                            End With
                            End If
                            
                            
                        End With
                End With
        End If
 Cells(LSTRW + 1, 1).EntireRow.Delete
  
    Next

End Sub
INSERT ROW WITH SPECIFIS TEXT IN A COLUMN.gif
 

xenios

Board Regular
Joined
Sep 4, 2020
Messages
88
Office Version
  1. 2016
Platform
  1. Windows
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
Yes, it still works the same way. Grey background is only in the 1st extra row and no uppercase. The upper case work as Ucase, I just don't know how to add to the code :(
 

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
17,247
Office Version
  1. 2013
Platform
  1. Windows
Wow. This task is giving more then me a challenge to get working. I will be watching to see what answer works.
 

Dossfm0q

Active Member
Joined
Mar 9, 2009
Messages
483
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Sub INSERT_ROW_WITH_SPECIFIS_TEXT_IN_A_COLUMN.xlsm
ABCDEFGH
112345678
2Juice
3Juice
4Juice
5Juice
6Juice
7Juice
8Melon
9Melon
10Melon
11Melon
12Melon
13Straw
14Straw
15Straw
16Straw
17Straw
18Straw
Sheet1


to be into Worksheet Module
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim TblRng As Range: Set TblRng = Range("A1:H15")
Dim B As Long
''''''''''
Dim ClNo As Long: ClNo = 6 '<<<<<<<<<<<
''''''''''
Dim LstRw As Long: LstRw = Cells(Rows.Count, ClNo).End(xlUp).Row
Dim GidelnRng As Range: Set GidelnRng = TblRng.Cells(1, ClNo).Resize(LstRw, 1)
Dim Adrs As Range
    If Target.Column = GidelnRng.Column Then
            If Target.Row = 1 Then
            If Target.Value = Target.Offset(1, 0).Value Then
                    RwAdrs = Target.EntireRow.Address
                    For B = 7 To 10
                    Target.Borders(B).LineStyle = xlNone
                    Next
                    
                    With TblRng.Rows(Target.Row).Cells
                            For B = 7 To 12
                                With .Borders(B)
                                    .LineStyle = xlContinuous
                                    .Color = 0
                                    .Weight = xlThin
                                End With
                            Next
                            
                            With .Interior
                                .Pattern = xlNone
                            End With
                    End With
                    
                    Rows(RwAdrs).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    Target.Offset(-1, -3).Value = Target.Value
                    Target.Offset(0, -3).Value = Null
                        With TblRng.Rows(Target.Row).Offset(-2, 0).Cells
                      
                        For B = 11 To 12
                                .Borders(B).LineStyle = xlNone
                        Next
                        For B = 7 To 10
                            With .Borders(B)
                                .LineStyle = xlContinuous
                                .Color = 255
                                .Weight = xlThin
                            End With
                        Next
                        With .Interior
                            .Pattern = xlSolid
                            .Color = RGB(191, 191, 191)
                        End With
                        End With
                    
                    
            Else
                        With TblRng.Rows(Target.Row).Cells
                      
                        For B = 7 To 12
                            With .Borders(B)
                                .LineStyle = xlContinuous
                                .Color = 5
                                .Weight = xlThin
                            End With
                        Next
                            With .Interior
                                .Pattern = xlNone
                            End With
                        
                        End With
                        
                        RwAdrs = Target.EntireRow.Address
                        Rows(RwAdrs).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        RwosAdrs = Target.Offset(1, 0).EntireRow.Address
                        Target.Offset(-1, -3).Value = Target.Value
                        Rows(RwosAdrs).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        Target.Offset(1, -3).Value = Target.Offset(2, 0).Value
                        Target.Offset(0, -3).Value = Null
                        
                        With TblRng.Rows(Target.Row).Offset(-2, 0).Cells
                      
                        For B = 11 To 12
                                .Borders(B).LineStyle = xlNone
                        Next
                        For B = 7 To 10
                            With .Borders(B)
                                .LineStyle = xlContinuous
                                .Color = 255
                                .Weight = xlThin
                            End With
                        Next
                        With .Interior
                            .Pattern = xlSolid
                            .Color = RGB(191, 191, 191)
                        End With
                        End With
                      
                       With TblRng.Rows(Target.Row).Cells

                        For B = 11 To 12
                                .Borders(B).LineStyle = xlNone
                        Next
                        For B = 7 To 10
                            With .Borders(B)
                                .LineStyle = xlContinuous
                                .Color = 255
                                .Weight = xlThin
                            End With
                        Next
                        With .Interior
                            .Pattern = xlSolid
                            .Color = RGB(191, 191, 191)
                        End With
                        
                        End With
            End If
                    
    
            Else
                If Target.Value <> "" Then
                    If Target.Value = Target.Offset(-1, 0).Value And Target.Value <> Target.Offset(1, 0).Value Then
                  
                    RwosAdrs = Target.Offset(1, 0).EntireRow.Address
                     Rows(RwosAdrs).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                     Target.Offset(0, -3).Value = Null
                     Target.Offset(1, -3).Value = Target.Offset(2, 0).Value
                     With TblRng.Rows(Target.Row).Cells
                        For B = 7 To 12
                            With .Borders(B)
                                .LineStyle = xlContinuous
                                .Color = 0
                                .Weight = xlThin
                            End With
                        Next
                            With .Interior
                                .Pattern = xlNone
                            End With
                        End With
                    ElseIf Target.Value <> Target.Offset(-1, 0).Value And Target.Value = Target.Offset(1, 0).Value Then
                        
                        RwAdrs = Target.EntireRow.Address
                        With TblRng.Rows(Target.Row).Cells
                        For B = 7 To 12
                        .Borders(B).LineStyle = xlNone
                        Next
                        End With
                        Rows(RwAdrs).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        Target.Offset(-1, -3).Value = Target.Value
                        Target.Offset(0, -3).Value = Null
                        With TblRng.Rows(Target.Row).Cells
                        For B = 7 To 12
                            With .Borders(B)
                                .LineStyle = xlContinuous
                                .Color = 255
                                .Weight = xlThin
                            End With
                        Next
                            With .Interior
                                .Pattern = xlNone
                            End With
                        End With
                        With TblRng.Rows(Target.Row).Offset(-1, 0).Cells
                      
                        For B = 11 To 12
                                .Borders(B).LineStyle = xlNone
                        Next
                        For B = 7 To 10
                            With .Borders(B)
                                .LineStyle = xlContinuous
                                .Color = 255
                                .Weight = xlThin
                            End With
                        Next
                        With .Interior
                            .Pattern = xlSolid
                            .Color = RGB(191, 191, 191)
                        End With
                        End With
                        
                        
                        
                    ElseIf Target.Value <> Target.Offset(-1, 0).Value And Target.Value <> Target.Offset(1, 0).Value Then
                        
                        With TblRng.Rows(Target.Row).Cells
                      
                             For B = 11 To 12
                             .Borders(B).LineStyle = xlNone
                                With .Interior
                                    .Pattern = xlSolid
                                    .Color = RGB(191, 191, 191)
                                End With
                            
                             Next
                        End With
                        RwAdrs = Target.EntireRow.Address
                        Rows(RwAdrs).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        RwosAdrs = Target.Offset(1, 0).EntireRow.Address
                        Target.Offset(-1, -3).Value = Target.Value
                        Rows(RwosAdrs).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        Target.Offset(1, -3).Value = Target.Offset(2, 0).Value
                        Target.Offset(0, -3).Value = Null
                        
                        With TblRng.Rows(Target.Row).Offset(-1, 0).Cells
                      
                             For B = 11 To 12
                             .Borders(B).LineStyle = xlNone
                                With .Interior
                                    .Pattern = xlSolid
                                    .Color = RGB(191, 191, 191)
                                End With
                            
                             Next
                        End With
                        
                        With TblRng.Rows(Target.Row).Cells
                        For B = 7 To 12
                            With .Borders(B)
                                .LineStyle = xlContinuous
                                .Color = 255
                                .Weight = xlThin
                            End With
                        Next
                            With .Interior
                                .Pattern = xlNone
                            End With
                        End With

                    End If
                End If
            End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub
 

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
781
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Here is a test file with the same code In #21
Tell me about it
 

xenios

Board Regular
Joined
Sep 4, 2020
Messages
88
Office Version
  1. 2016
Platform
  1. Windows
Or rather this the final code hope It's ok with you
VBA Code:
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)) = UCase(Range(.Items()(i)).Offset(1))
            Range(.Items()(i)).Interior.ColorIndex = 16
            Range(.Items()(i)).Offset(, -5).Resize(, 7).Merge
            Range(.Items()(i)).HorizontalAlignment = xlCenter
        Next
    End With
    Application.ScreenUpdating = True
End Sub
This one is good! Thank you!!!
 

xenios

Board Regular
Joined
Sep 4, 2020
Messages
88
Office Version
  1. 2016
Platform
  1. Windows
Thank you all the for the answers!!!
 

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
781
Office Version
  1. 2013
Platform
  1. Windows
You are very welcome
And thank you for the feedback
Be happy
 

Watch MrExcel Video

Forum statistics

Threads
1,118,265
Messages
5,571,216
Members
412,368
Latest member
saranbl
Top