INSERT ROW WITH SPECIFIS TEXT IN A COLUMN

xenios

xenios

Board Regular
Joined
Sep 4, 2020
Messages
91
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: 23
Sort by date Sort by votes
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
 
Upvote 0
Solution

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
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
 
Upvote 0
mohadin said:
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
Click to expand...
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 :(
 
Upvote 0
Wow. This task is giving more then me a challenge to get working. I will be watching to see what answer works.
 
Upvote 0
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
 
Upvote 0
mohadin said:
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
Click to expand...
This one is good! Thank you!!!
 
Upvote 0
You are very welcome
And thank you for the feedback
Be happy
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
ActiveSheet. Paste error
Replies
1
Views
344
RoryA
RoryA
P
  • Question Question
Help with Vba Code
Replies
3
Views
464
Coyotex3
C
An Quala
  • Question Question
Should I name it Active.Sheet or sheet name?
Replies
8
Views
896
MARK858
MARK858
M
  • Question Question
VBS Crash
Replies
1
Views
761
Alex Blakenburg
A
S
  • Question Question
What could be refreshing my ODBC connections in this code?
Replies
0
Views
659
sspatriots
S

Forum statistics

Threads
1,223,911
Messages
6,175,327
Members
452,635
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top