Insert multiple rows with fill number in a specific row

[Unexpc]

Hi guys
i have several customer in a sheet that have separator (a gray row) between every customer, now, when i write a number in this rows, insert rows up with that amount

 

[kanadaaa]

First, place this code in a standard module:

Sub CheckInteriorColourIndex()
    MsgBox Selection.Interior.ColorIndex
End Sub

Then select a separator cell coloured in grey and run the macro.
Colour index will pop up, so remember that number.

Then try the code below in a sheet module (replace the number 15 with the number you saw in the message box):

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Interior.ColorIndex = 15 And Not IsEmpty(Target) Then
        On Error GoTo errHandler
        Rows(Target.Row & ":" & Target.Row + CInt(Target) - 1).Insert Shift:=xlDown
        On Error GoTo 0
    End If
Exit Sub
errHandler:
    MsgBox "Row insertion failed: Number invalid", vbExclamation, "Error"
End Sub

 

[Unexpc]

First, place this code in a standard module:

Sub CheckInteriorColourIndex()
    MsgBox Selection.Interior.ColorIndex
End Sub

Then select a separator cell coloured in grey and run the macro.
Colour index will pop up, so remember that number.

Then try the code below in a sheet module (replace the number 15 with the number you saw in the message box):

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Interior.ColorIndex = 15 And Not IsEmpty(Target) Then
        On Error GoTo errHandler
        Rows(Target.Row & ":" & Target.Row + CInt(Target) - 1).Insert Shift:=xlDown
        On Error GoTo 0
    End If
Exit Sub
errHandler:
    MsgBox "Row insertion failed: Number invalid", vbExclamation, "Error"
End Sub

i test it, when i run fisrt code, that is show break mode error, and how does it work?

 

[kanadaaa]

You have to put it into a standard module.

 

[Unexpc]

You have to put it into a standard module.

yeah, i put it in module (for me module 1) but not work, can you send a screenshot? thank you

 

[Unexpc]

You have to put it into a standard module.

one question, i don't know about that, but i first insert first code at module 1 and run that macro and show error, after that i copy/paste second code in that module and run macro but not doing anything, anyway doing automatically macro?(i write for example number 2 in gray row and after that insert two rows in up of that row)

 

[maabadi]

What is column name that you input Number? A, B or ....

 

[maabadi]

Combined Code for Work Sheet with Previous Worksheet Change Event isThis:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, Lr1 As Long, Lr2 As Long, Cr As Long, Lr3 As Long, Lr4 As Long, K As Long, CrR As String
Lr1 = Sheets("Dashboard").Range("I" & Rows.Count).End(xlUp).Row
Lr2 = Sheets("Dashboard").Range("N" & Rows.Count).End(xlUp).Row
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row

If Intersect(Target, Union(Range("A1:A" & Lr3), Range("E3:E1048576,G3:G1048576"))) Is Nothing Then Exit Sub
If Not Intersect(Target, Range("E3:E1048576,G3:G1048576")) Is Nothing Then
If Target.Count = 1 Then
If Target.Value > 0 Then Target = Target.Value * -1
End If
End If
On Error Resume Next
If Intersect(Target, Range("A1:A" & Lr3)) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target.Interior.Color = 14277081 And Target.Value <> "" Then
Range("A" & Target.Row & ":G" & Target.Row + Target.Value).Insert Shift:=xlDown
Target.Value = ""
End If
  For i = 3 To Lr1 - 1
    Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
    CrR = Range("A" & Cr).Address
    Sheets("Dashboard").Range("I" & i).Hyperlinks.Delete
    Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("I" & i).Value
       With Sheets("Dashboard").Range("I" & i).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlColorIndexAutomatic
                .Name = "Arial"
                .Size = 14
     End With
Next i
Application.EnableEvents = True
End Sub

 

[Unexpc]

Combined Code for Work Sheet with Previous Worksheet Change Event isThis:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, Lr1 As Long, Lr2 As Long, Cr As Long, Lr3 As Long, Lr4 As Long, K As Long, CrR As String
Lr1 = Sheets("Dashboard").Range("I" & Rows.Count).End(xlUp).Row
Lr2 = Sheets("Dashboard").Range("N" & Rows.Count).End(xlUp).Row
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row

If Intersect(Target, Union(Range("A1:A" & Lr3), Range("E3:E1048576,G3:G1048576"))) Is Nothing Then Exit Sub
If Not Intersect(Target, Range("E3:E1048576,G3:G1048576")) Is Nothing Then
If Target.Count = 1 Then
If Target.Value > 0 Then Target = Target.Value * -1
End If
End If
On Error Resume Next
If Intersect(Target, Range("A1:A" & Lr3)) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target.Interior.Color = 14277081 And Target.Value <> "" Then
Range("A" & Target.Row & ":G" & Target.Row + Target.Value).Insert Shift:=xlDown
Target.Value = ""
End If
  For i = 3 To Lr1 - 1
    Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
    CrR = Range("A" & Cr).Address
    Sheets("Dashboard").Range("I" & i).Hyperlinks.Delete
    Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("I" & i).Value
       With Sheets("Dashboard").Range("I" & i).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlColorIndexAutomatic
                .Name = "Arial"
                .Size = 14
     End With
Next i
Application.EnableEvents = True
End Sub

yes, thats it, but two problem
1.this is add 1 more row than number i write
2.when i delete a count multiple rows, delete that count multiple data below of last delete multiple rows

 

[maabadi]

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, j As Long, Lr1 As Long, Lr2 As Long, Cr As Long, CrR As String
Dim Lr3 As Long, Lr4 As Long, K As Long
Lr1 = Sheets("Dashboard").Range("I" & Rows.Count).End(xlUp).Row
Lr2 = Sheets("Dashboard").Range("N" & Rows.Count).End(xlUp).Row
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row

  If Intersect(Target, Union(Range("A1:A" & Lr3), Range("E3:E1048576,G3:G1048576"))) Is Nothing Then Exit Sub
   If Not Intersect(Target, Range("E3:E1048576,G3:G1048576")) Is Nothing Then
   If Target.Count = 1 Then
   If Target.Value > 0 Then Target = Target.Value * -1
   End If
   End If
   On Error Resume Next
  If Intersect(Target, Range("A1:A" & Lr3)) Is Nothing Then Exit Sub
  Application.EnableEvents = False
  If Target.Interior.Color = 14277081 Then
  If Target.Value <> "" Then
  Range("A" & Target.Row & ":G" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
  Target.Value = ""
  End If
  End If
  For i = 3 To Lr1 - 1
   Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
   CrR = Range("A" & Cr).Address
     Sheets("Dashboard").Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("I" & i).Value
     With Sheets("Dashboard").Range("I" & i)
                .Font.Underline = xlUnderlineStyleNone
                .Font.ColorIndex = xlColorIndexAutomatic
                .Font.Name = "Arial"
                .Font.Size = 14
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
     End With
  Next i
  Application.EnableEvents = True
End Sub