INSERT ROW WITH SPECIFIS TEXT IN A COLUMN

xenios · Oct 22, 2020

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

mohadin · Oct 25, 2020

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

Dossfm0q · Oct 26, 2020

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 · Oct 26, 2020

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

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 · Oct 26, 2020

Wow. This task is giving more then me a challenge to get working. I will be watching to see what answer works.

Dossfm0q · Oct 26, 2020

Sub INSERT_ROW_WITH_SPECIFIS_TEXT_IN_A_COLUMN.xlsm

A

B

C

D

E

F

G

H

1

2

3

4

5

6

7

8

2

Juice

3

Juice

4

Juice

5

Juice

6

Juice

7

Juice

8

Melon

9

Melon

10

Melon

11

Melon

12

Melon

13

Straw

14

Straw

15

Straw

16

Straw

17

Straw

18

Straw

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

Dossfm0q · Oct 26, 2020

Attachment

mohadin · Oct 26, 2020

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

xenios.xlsm

Shared with Dropbox

www.dropbox.com

xenios · Oct 26, 2020

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

This one is good! Thank you!!!

xenios · Oct 26, 2020

Thank you all the for the answers!!!

mohadin · Oct 26, 2020

You are very welcome
And thank you for the feedback
Be happy

INSERT ROW WITH SPECIFIS TEXT IN A COLUMN

xenios

Board Regular

Attachments

mohadin

Well-known Member

Excel Facts

Dossfm0q

Banned User

xenios

Board Regular

My Aswer Is This

Well-known Member

Dossfm0q

Banned User

Dossfm0q

Banned User

mohadin

Well-known Member

xenios.xlsm

xenios

Board Regular

xenios

Board Regular

mohadin

Well-known Member

Similar threads

Forum statistics

Share this page

INSERT ROW WITH SPECIFIS TEXT IN A COLUMN

Board Regular

Attachments

Well-known Member

Excel Facts

Banned User

Board Regular

Well-known Member

Banned User

Banned User

Well-known Member

Board Regular

Board Regular

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock