Insert row below named range while extending that range

[DJFANDANGO]

Good evening all,

Question... (obviously)

Is there a way of making a VBA to insert a single row below the last 'Dep' 'C:C' while extending the range, "B4:J8" has been named "Third_Party", "B9:J10" = "QC", etc...

While the formulae in "D8:J8" (also in the named range of Third_Party) would just copy down.

I'd like to have a 'button' on the top row for each 'Dep' that would insert a row below each 'Dep' that I clicked on...

EXTRA CHALLENGE... (IF POSSIBLE)

Button to insert NEW DEP, but that 'Dep' (Department) button/VBA would create a new row in alphabetical order, e.j. if I wanted to add a 'Dep' called "Pro" it would automatically insert a row above "Ops"
I would make separate sheet with 'Departments' listed on it.

Any help greatly appreciated...

 

[DanteAmor]

Is there a way of making a VBA to insert a single row below the last 'Dep' 'C:C' while extending the range, "B4:J8" has been named "Third_Party", "B9:J10" = "QC", etc...
While the formulae in "D8:J8" (also in the named range of Third_Party) would just copy down.
I'd like to have a 'button' on the top row for each 'Dep' that would insert a row below each 'Dep' that I clicked on...

With the following you only need one button. Just select a cell in column B where you want to insert a row into the named range.
Continuing with your example, select cell B7, the macro will create row 9.

Sub Macro5()
  Dim nameR As String, rng As String, rng1 As String, rng2 As String
  Dim mAdrs As Variant, nRow As Long
  
  nameR = Replace(Range("B" & ActiveCell.Row), " ", "_")
  rng = ActiveWorkbook.Names(nameR).RefersTo
  rng1 = Left(rng, InStrRev(rng, "$"))
  mAdrs = Split(ActiveWorkbook.Names(nameR).RefersTo, "$")
  nRow = mAdrs(UBound(mAdrs)) + 1
  rng2 = rng1 & nRow
  Rows(nRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
  Range("D" & nRow - 1 & ":J" & nRow - 1).Copy Range("D" & nRow)
  Range("B" & nRow).Value = Range("B" & ActiveCell.Row)
  ActiveWorkbook.Names(nameR).RefersTo = rng2
End Sub

EXTRA CHALLENGE... (IF POSSIBLE)
Button to insert NEW DEP

Under construction ?

 

[DJFANDANGO]

Hi Dante!

Thank you so much, this is FANTASTIC! thanks for the help, I made one adjustment "CopyOrigin:=xlFormatFromRightOrAbove" as it was copying the colour of the next row below (different), other than that, I'm in my element now, you are a STAR!

Looking forward to the 'Under Construction' one! hehe

Thanks once again!

Best regards
Steve (DjFandango)

 

[DanteAmor]

Looking forward to the 'Under Construction' one!

Try this

Sub macro2()
  Dim newName As Variant, new_Name As String, nRng As Variant
  Dim i As Long, lr As Long, newRow As Long
  
  newName = Application.InputBox("New Named Range")
  If newName = "" Or newName = False Then Exit Sub
  
  If Left(newName, 1) Like "[1-9]" Then
    MsgBox "Invalid named range"
    Exit Sub
  End If
  new_Name = Replace(newName, " ", "_")
  For Each nRng In ThisWorkbook.Names
    If LCase(nRng.Name) = LCase(new_Name) Then
      MsgBox "The named range already exists"
      Exit Sub
    End If
  Next
  If Evaluate("ISREF(" & newName & ")") Then
    MsgBox "Invalid named range, it is the reference of a cell."
    Exit Sub
  End If
    
  lr = Range("B" & Rows.Count).End(3).Row
  newRow = lr + 1
  For i = 4 To lr
    If StrComp(newName, Range("B" & i).Value, vbTextCompare) = 1 Then
      newRow = i
      Exit For
    End If
  Next
  
  Rows(newRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
  If Range("D" & newRow - 1).HasFormula Then
    Range("D" & newRow - 1 & ":J" & newRow - 1).Copy Range("D" & newRow)
  ElseIf Range("D" & newRow + 1).HasFormula Then
    Range("D" & newRow + 1 & ":J" & newRow + 1).Copy Range("D" & newRow)
  End If
  Range("B" & newRow).Value = new_Name
  ActiveWorkbook.Names.Add new_Name, "='" & ActiveSheet.Name & "'!" & Range("B" & newRow & ":J" & newRow).Address
End Sub

 

[DJFANDANGO]

Hi Dante, as mentioned the VBA works well, what it doesn't do (maybe i forgot to mention), but, as it copies the the named range down, it is not making a 'drag down' of the formula that is in (C:C)...

Can you help with editing the VBA>?

Many thanks.

 

[DJFANDANGO]

Hi Dante,

It works for any department named before 'Deck', but not copying cell format, but as soon as I go up the alphabet, it's putting the cell above 'Dep'...

Any ideas?... Muchisimas Gracias!

Many thanks for your help with this...

 

[DanteAmor]

Try this:

Sub Macro5()
  Dim nameR As String, rng As String, rng1 As String, rng2 As String
  Dim mAdrs As Variant, nRow As Long
  
  nameR = Replace(Range("B" & ActiveCell.Row), " ", "_")
  rng = ActiveWorkbook.Names(nameR).RefersTo
  rng1 = Left(rng, InStrRev(rng, "$"))
  mAdrs = Split(ActiveWorkbook.Names(nameR).RefersTo, "$")
  nRow = mAdrs(UBound(mAdrs)) + 1
  rng2 = rng1 & nRow
  Rows(nRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
  Range("C" & nRow - 1 & ":J" & nRow - 1).Copy Range("C" & nRow)
  Range("B" & nRow).Value = Range("B" & ActiveCell.Row)
  ActiveWorkbook.Names(nameR).RefersTo = rng2
End Sub

Sub macro2()
  Dim newName As Variant, new_Name As String, nRng As Variant
  Dim i As Long, lr As Long, newRow As Long
  
  newName = Application.InputBox("New Named Range")
  If newName = "" Or newName = False Then Exit Sub
  
  If Left(newName, 1) Like "[1-9]" Then
    MsgBox "Invalid named range"
    Exit Sub
  End If
  new_Name = Replace(newName, " ", "_")
  For Each nRng In ThisWorkbook.Names
    If LCase(nRng.Name) = LCase(new_Name) Then
      MsgBox "The named range already exists"
      Exit Sub
    End If
  Next
  If Evaluate("ISREF(" & newName & ")") Then
    MsgBox "Invalid named range, it is the reference of a cell."
    Exit Sub
  End If
    
  lr = Range("B" & Rows.Count).End(3).Row
  newRow = lr + 1
  For i = 4 To lr
    If StrComp(newName, Range("B" & i).Value, vbTextCompare) = 1 Then
      newRow = i
      Exit For
    End If
  Next
  
  Rows(newRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
  If Range("C" & newRow - 1).HasFormula Then
    Range("C" & newRow - 1 & ":J" & newRow - 1).Copy Range("C" & newRow)
  ElseIf Range("C" & newRow + 1).HasFormula Then
    Range("C" & newRow + 1 & ":J" & newRow + 1).Copy Range("C" & newRow)
  End If
  Range("B" & newRow).Value = new_Name
  ActiveWorkbook.Names.Add new_Name, "='" & ActiveSheet.Name & "'!" & Range("B" & newRow & ":J" & newRow).Address
End Sub