Press a cell and then create cells with specific formula

U

Unexpc

Active Member
Joined
Nov 12, 2020
Messages
496
Office Version
  1. 2019
Platform
  1. Windows
Hi guys
i have sheet that just list of customers, i insert costumers name in one column and other data i want to have in next columns
for name of customers of have this formula : =HYPERLINK("#'Sheet name'!A"&MATCH("Name of Customer",Sheet name!A:A,0),"Name of Customer")
sheet name that is sheet customer that belong data in it, for example for me Work for sheet name
another formula this is in next columns
=IFERROR(INDEX(Sheet name!B:B,MATCH($I4,Sheet name!A:A,0)-2,0),"")
=IFERROR(SUM(INDEX(Sheet name!D:D,MATCH($I3,Sheet name!A:A,0)+1,0):INDEX(Sheet name!E:E,MATCH($I4,Sheet name!A:A,0)-2,0)),"")
=IFERROR(SUM(INDEX(Sheet name!F:F,MATCH($I3,Sheet name!A:A,0)+1,0):INDEX(Sheet name!G:G,MATCH($I4,Sheet name!A:A,0)-2,0)),"")
this 3 formulas drag and fill in next rows
now
i want when select cell after last customer that may write NEW CUSTOMER, create a new first formula with the name that i write and then drag and fill this 3 formulas in that row and still stay this cell NEW CUSTOMER after that...
 

Attachments

  • Screenshot 2021-03-27 180521.png
    Screenshot 2021-03-27 180521.png
    7 KB · Views: 18
  • Screenshot 2021-03-27 180524.png
    Screenshot 2021-03-27 180524.png
    11.6 KB · Views: 16
Sort by date Sort by votes
Yes. this is problem. I modify it & sent for you mixed code.
 
Upvote 0

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
This is Mixed Code for Work Sheet:
VBA Code: 
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
  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:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & CrR, TextToDisplay:=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

AND for Paper Sheet:
VBA Code: 
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" & Lr4), 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" & Lr4)) Is Nothing Then Exit Sub
 Application.EnableEvents = False
  For i = 3 To Lr2 - 1
    Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & i).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
    CrR = Range("A" & Cr).Address
    Sheets("Dashboard").Range("N" & i).Hyperlinks.Delete
    Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & CrR, TextToDisplay:=Range("N" & i).Value
       With Sheets("Dashboard").Range("N" & i).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlColorIndexAutomatic
                .Name = "Arial"
                .Size = 14
     End With
Next i
Application.EnableEvents = True
End Sub
 
Upvote 0
maabadi said:
This is Mixed Code for Work Sheet:
VBA Code: 
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
  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:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & CrR, TextToDisplay:=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

AND for Paper Sheet:
VBA Code: 
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" & Lr4), 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" & Lr4)) Is Nothing Then Exit Sub
Application.EnableEvents = False
  For i = 3 To Lr2 - 1
    Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & i).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
    CrR = Range("A" & Cr).Address
    Sheets("Dashboard").Range("N" & i).Hyperlinks.Delete
    Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & CrR, TextToDisplay:=Range("N" & i).Value
       With Sheets("Dashboard").Range("N" & i).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlColorIndexAutomatic
                .Name = "Arial"
                .Size = 14
     End With
Next i
Application.EnableEvents = True
End Sub
Click to expand...
i tested, when i add row in work and paper, in dashboard like remove hyperlink (that is not show pointer and anything that link to the customer and this like a text)
 
Upvote 0
Yes. I do to Remove Previous Hyperlink and add New Hyperlink.
Are you test Data at column I after adding row in Work. I set to hyperlink again and change font & color.
 
Upvote 0
maabadi said:
Yes. I do to Remove Previous Hyperlink and add New Hyperlink.
Are you test Data at column I after adding row in Work. I set to hyperlink again and change font & color.
Click to expand...
yes, when create a customer after give a name in inputbox, hyperlink is work correctly, after i added row in work, hyperlink like removed and just keep text of that
 
Upvote 0
Try these Codes:
For Work Sheet:
VBA Code: 
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
  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
For Paper Sheet:
VBA Code: 
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" & Lr4), 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" & Lr4)) Is Nothing Then Exit Sub
 Application.EnableEvents = False
  For i = 3 To Lr2 - 1
    Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & i).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
    CrR = Range("A" & Cr).Address
    Sheets("Dashboard").Range("N" & i).Hyperlinks.Delete
    Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("N" & i).Value
       With Sheets("Dashboard").Range("N" & i).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlColorIndexAutomatic
                .Name = "Arial"
                .Size = 14
     End With
Next i
Application.EnableEvents = True
End Sub
 
Upvote 0
maabadi said:
Try these Codes:
For Work Sheet:
VBA Code: 
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
  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
For Paper Sheet:
VBA Code: 
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" & Lr4), 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" & Lr4)) Is Nothing Then Exit Sub
Application.EnableEvents = False
  For i = 3 To Lr2 - 1
    Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & i).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
    CrR = Range("A" & Cr).Address
    Sheets("Dashboard").Range("N" & i).Hyperlinks.Delete
    Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("N" & i).Value
       With Sheets("Dashboard").Range("N" & i).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlColorIndexAutomatic
                .Name = "Arial"
                .Size = 14
     End With
Next i
Application.EnableEvents = True
End Sub
Click to expand...
Yes, this is correct work, just not centered name of customer in dashboard and always been left after i add row in work and paper :(
 
Upvote 0
Add this lines Before Next i at Both Sheets
Work Sheet:
VBA Code: 
 Sheets("Dashboard").Range("I" & i).HorizontalAlignment = xlCenter
Sheets("Dashboard").Range("I" & i).VerticalAlignment = xlCenter
Paper Sheet:
VBA Code: 
Sheets("Dashboard").Range("N" & i).HorizontalAlignment = xlCenter
Sheets("Dashboard").Range("N" & i).VerticalAlignment = xlCenter
 
Upvote 0
maabadi said:
Add this lines Before Next i at Both Sheets
Work Sheet:
VBA Code: 
 Sheets("Dashboard").Range("I" & i).HorizontalAlignment = xlCenter
Sheets("Dashboard").Range("I" & i).VerticalAlignment = xlCenter
Paper Sheet:
VBA Code: 
Sheets("Dashboard").Range("N" & i).HorizontalAlignment = xlCenter
Sheets("Dashboard").Range("N" & i).VerticalAlignment = xlCenter
Click to expand...
Awesome, you solved problems with your genius, please upload all code #69 + #86 in one post i mark as solution
 
Upvote 0
This is Code:
Excel Formula: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long, j As Long, Lr1 As Long, Lr2 As Long, Cr1 As Long, Cr1R As String, Cr2 As Long, Cr2R As String
Dim Lr3 As Long, Lr4 As Long, M1 As Long, M2 As Long, Cr3 As Variant
Lr1 = Range("I" & Rows.Count).End(xlUp).Row
Lr2 = 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


On Error Resume Next


  If Intersect(Target, Union(Range("I" & Lr1), Range("N" & Lr2))) Is Nothing Then Exit Sub
   If Target.Count > 1 Then Exit Sub
  If Not Intersect(Target, Range("I" & Lr1)) Is Nothing Then
     Application.EnableEvents = False
     Cr3 = Application.InputBox(prompt:="Please Input New Customer Name", Type:=2)
     If Cr3 = False Then
     Application.EnableEvents = True
     Exit Sub
     Else
     Range("I" & Lr1 & ":M" & Lr1).Insert Shift:=xlDown
     i = Application.WorksheetFunction.Match(Cr3, Sheets("Work").Range("A1:A" & Lr3), 0)
     If i = False Then
     i = Application.WorksheetFunction.Match("New Customer", Sheets("Work").Range("A1:A" & Lr3), 0)
     Sheets("Work").Range("A" & i & ":G" & i + 3).Copy Sheets("Work").Range("A" & i + 4 & ":G" & i + 7)
     Sheets("Work").Range("A" & i).Value = Cr3
     End If
     End If
     Range("I" & Lr1).Value = Sheets("Work").Range("A" & i).Value
     If Lr1 = 3 Then
     Range("J" & Lr1).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & Lr1).FormulaR1C1 = "=IFERROR(SUM(INDEX(Work!C[-7],MATCH(RC9,Work!C[-10],0)+1,0):INDEX(Work!C[-6],MATCH(R[1]C9,Work!C[-10],0)-2,0)),"""")"
     Range("L" & Lr1).FormulaR1C1 = "=IFERROR(SUM(INDEX(Work!C[-6],MATCH(RC9,Work!C[-11],0)+1,0):INDEX(Work!C[-5],MATCH(R[1]C9,Work!C[-11],0)-2,0)),"""")"
     ElseIf Lr1 > 3 Then
     Range("J" & Lr1 - 1 & ":J" & Lr1).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & Lr1 - 1 & ":K" & Lr1).FormulaR1C1 = "=IFERROR(SUM(INDEX(Work!C[-7],MATCH(RC9,Work!C[-10],0)+1,0):INDEX(Work!C[-6],MATCH(R[1]C9,Work!C[-10],0)-2,0)),"""")"
     Range("L" & Lr1 - 1 & ":L" & Lr1).FormulaR1C1 = "=IFERROR(SUM(INDEX(Work!C[-6],MATCH(RC9,Work!C[-11],0)+1,0):INDEX(Work!C[-5],MATCH(R[1]C9,Work!C[-11],0)-2,0)),"""")"
  
     End If


     Cr1R = Range("A" & i).Address
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & Lr1), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=Range("I" & Lr1).Value
     With Sheets("Dashboard").Range("I" & Lr1).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlColorIndexAutomatic
                .Name = "Arial"
                .Size = 14
     End With
     Sheets("Work").Activate
     Sheets("Work").Range("A" & i).Select
     Sheets("Work").Range("A" & i).Font.ColorIndex = 1
Application.EnableEvents = True

  End If
    If Not Intersect(Target, Range("N" & Lr2)) Is Nothing Then
    If Target.Count = 1 Then
    Application.EnableEvents = False
     Cr3 = Application.InputBox(prompt:="Please Input New Customer Name", Type:=2)
     If Cr3 = False Then
     Application.EnableEvents = True
     Exit Sub
     Else
     Range("N" & Lr2 & ":Q" & Lr2).Insert Shift:=xlDown
     i = Application.WorksheetFunction.Match(Cr3, Sheets("Paper").Range("A1:A" & Lr4), 0)
     If i = False Then
     i = Application.WorksheetFunction.Match("New Customer", Sheets("Paper").Range("A1:A" & Lr4), 0)
     Sheets("Paper").Range("A" & i & ":G" & i + 3).Copy Sheets("Paper").Range("A" & i + 4 & ":G" & i + 7)
     Sheets("Paper").Range("A" & i).Value = Cr3
     End If
     End If
     Range("N" & Lr2).Value = Sheets("Paper").Range("A" & i).Value
     If Lr2 = 3 Then
     Range("O" & Lr2).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & Lr2).FormulaR1C1 = "=IFERROR(SUM(INDEX(Paper!C[-12],MATCH(RC14,Paper!C[-15],0)+1,0):INDEX(Paper!C[-11],MATCH(R[1]C14,Paper!C[-15],0)-2,0)),"""")"
     Range("Q" & Lr2).FormulaR1C1 = "=IFERROR(SUM(INDEX(Paper!C[-11],MATCH(RC14,Paper!C[-16],0)+1,0):INDEX(Paper!C[-10],MATCH(R[1]C14,Paper!C[-16],0)-2,0)),"""")"
     ElseIf Lr2 > 3 Then
     Range("O" & Lr2 - 1 & ":O" & Lr2).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & Lr2 - 1 & ":P" & Lr2).FormulaR1C1 = "=IFERROR(SUM(INDEX(Paper!C[-12],MATCH(RC14,Paper!C[-15],0)+1,0):INDEX(Paper!C[-11],MATCH(R[1]C14,Paper!C[-15],0)-2,0)),"""")"
     Range("Q" & Lr2 - 1 & ":Q" & Lr2).FormulaR1C1 = "=IFERROR(SUM(INDEX(Paper!C[-11],MATCH(RC14,Paper!C[-16],0)+1,0):INDEX(Paper!C[-10],MATCH(R[1]C14,Paper!C[-16],0)-2,0)),"""")"
     End If
      Cr2R = Range("A" & i).Address
      Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & Lr2), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr2R, TextToDisplay:=Range("N" & Lr2).Value
      With Sheets("Dashboard").Range("N" & Lr2).Font
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlColorIndexAutomatic
                .Name = "Arial"
                .Size = 14
     End With
     Sheets("Paper").Activate
     Sheets("Paper").Range("A" & i).Select
     Sheets("Paper").Range("A" & i).Font.ColorIndex = 1
    Application.EnableEvents = True
   End If
  End If
End Sub
I realized with this code & also With Hyperlink Formula after Inserting OR Deleting Row, Hyperlink go to Wrong Row then You should add this worksheet Selection-Change event to Work & Paper Worksheets:

For Work Sheet:
VBA Code: 
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
  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

For Paper sheet:
VBA Code: 
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" & Lr4), 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" & Lr4)) Is Nothing Then Exit Sub
Application.EnableEvents = False
  For i = 3 To Lr2 - 1
    Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & i).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
    CrR = Range("A" & Cr).Address
    Sheets("Dashboard").Range("N" & i).Hyperlinks.Delete
    Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("N" & i).Value
       With Sheets("Dashboard").Range("N" & 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
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

G
  • Question
VBA - add formula to cell when created
Replies
2
Views
285
Golaidron
G
I
  • Question
Copy worksheet but the new worksheet to omit some items
2
Replies
11
Views
419
ipbr21054
I
szita2000
  • Question
Index Match Match from a named table to a range
Replies
1
Views
279
Alex Blakenburg
A
B
  • Question
Copy formula into a cell using vba
2
Replies
11
Views
417
BobtBuilder
B
G
  • Solved
Extract the cells that contains alphanumeric string from the column
Replies
6
Views
365
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,214,614
Messages
6,120,530
Members
448,969
Latest member
mirek8991

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