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: 17
Sort by date Sort by votes
maabadi said:
It cann't be done, Because when you want Insert rows for adding new customer then you see error because you have data at last row and then they don't have rows to go down.
Click to expand...
no problem, THANK YOU, just please upload code #136 without hidden
 
Upvote 0

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
maabadi said:
It cann't be done, Because when you want Insert rows for adding new customer then you see error because you have data at last row and then they don't have rows to go down.
Click to expand...
But, anyway you find problem and fix it, im very thankful
 
Upvote 0
I find One Way. First Move New Customer Rows to Last 4 rows at Work & Paper Sheets
Second Hide Both at Both Sheets.
Then Try these codes:
VBA Code: 
Private Sub Worksheet_Change(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
On Error Resume Next
Lr1 = Range("I" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
Lr2 = Range("N" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
If Intersect(Target, Union(Range("I3:I" & Lr1 + Target.Rows.Count - 1), Range("N3:N" & Lr2 + Target.Rows.Count - 1))) Is Nothing Then Exit Sub
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
If Not Intersect(Target, Range("I3:I" & Lr1 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("I" & Target.Row - 1), Sheets("Work").Range("A1:A" & Lr3), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum2
End If
For i = M1 + 2 To Lr3
If Sheets("work").Range("A" & i).Interior.Color = 4697456 Then
M1 = i
GoTo Resum2
End If
Next i
Resum2:
M2 = Application.WorksheetFunction.Match(Range("I" & Target.Row), Sheets("Work").Range("A1:A" & Lr3), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum7
       End If
       Next i
End If
Resum7:
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Work").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Work").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr1 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
For i = Target.Row To Lr1 - M1
  If i = 3 Then
     Range("J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i).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" & i).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 i > 3 Then
     Range("J" & i - 1 & ":J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i - 1 & ":K" & i).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" & i - 1 & ":L" & i).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
If i = Lr1 - Target.Rows.Count Then GoTo Resum5
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
Resum5:
M2 = Application.WorksheetFunction.Match("New Customer", Range("I1:I" & Lr1), 0)
Range("J" & M2 & ":L" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

If Not Intersect(Target, Range("N3:N" & Lr2 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("N" & Target.Row - 1), Sheets("Paper").Range("A1:A" & Lr4), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum3
End If
For i = M1 + 2 To Lr4
If Sheets("Paper").Range("A" & i).Interior.Color = 12874308 Then
M1 = i
GoTo Resum3
End If
Next i
Resum3:
M2 = Application.WorksheetFunction.Match(Range("N" & Target.Row), Sheets("Paper").Range("A1:A" & Lr4), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum8
       End If
       Next i
End If
Resum8:
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Paper").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Paper").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr2 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
For i = Target.Row To Lr2 - M1
  If i = 3 Then
     Range("O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i).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" & i).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 i > 3 Then
     Range("O" & i - 1 & ":O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i - 1 & ":P" & i).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" & i - 1 & ":Q" & i).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
If i = Lr2 - Target.Rows.Count + 1 Then GoTo Resum6
    Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
Resum6:
M2 = Application.WorksheetFunction.Match("New Customer", Range("N1:N" & Lr2), 0)
Range("O" & M2 & ":Q" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

Application.EnableEvents = True
End Sub

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, M3 As Long
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
     If Lr3 = 1 And Sheets("Work").Range("A1").Value = "" Then GoTo Resum3
     For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M3 = i + 1
       GoTo Resum3
       End If
       Next i
Resum3:
     If Lr3 = 1 And Sheets("Work").Range("A1").Value = "" Then M3 = 1
     Sheets("Dashboard").Range("I" & Lr1).Value = Cr3
     Worksheets("Dashboard").Sort.SortFields.Clear
     Range("I2:I" & Lr1).Sort Key1:=Range("I2"), Header:=xlYes, Order1:=xlAscending
     M2 = Application.WorksheetFunction.Match(Cr3, Sheets("Dashboard").Range("I1:I" & Lr1), 0)
     M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & M2 + 1).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
     Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
     Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Work").Range("A" & Rows.Count - 7)
     If M1 = 0 Then M1 = M3
     Sheets("Work").Range("A" & Rows.Count - 7 & ":G" & Rows.Count - 4).Copy
     Sheets("Work").Range("A" & M1 & ":G" & M1).Insert Shift:=xlDown
     Sheets("Work").Range("A" & M1).Value = Cr3
     Sheets("Work").Range("A" & M1).Font.ColorIndex = xlColorIndexAutomatic
     End If
     End If
   
  If M2 = 3 Then
     Range("J3").FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K3").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("L3").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)),"""")"
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  ElseIf M2 = 4 Then
     Range("J3").FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K3").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("L3").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)),"""")"
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  ElseIf M2 > 4 Then
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  End If
   For i = M2 To Lr1
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
     Sheets("Work").Activate
     Sheets("Work").Range("A" & M1).Select
     Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
     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
     If Lr4 = 1 And Sheets("Paper").Range("A1").Value = "" Then GoTo Resum4
     For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M3 = i + 1
       GoTo Resum4
       End If
       Next i
Resum4:
     If Lr4 = 1 And Sheets("Paper").Range("A1").Value = "" Then M3 = 1
     Sheets("Dashboard").Range("N" & Lr2).Value = Cr3
     Worksheets("Dashboard").Sort.SortFields.Clear
     Range("N2:N" & Lr2).Sort Key1:=Range("N2"), Header:=xlYes, Order1:=xlAscending
     M2 = Application.WorksheetFunction.Match(Cr3, Sheets("Dashboard").Range("N1:N" & Lr2), 0)
     M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & M2 + 1).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
     Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
     Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Paper").Range("A" & Rows.Count - 7)
     If M1 = 0 Then M1 = M3
     Sheets("Paper").Range("A" & Rows.Count - 7 & ":G" & Rows.Count - 4).Copy
     Sheets("Paper").Range("A" & M1 & ":G" & M1).Insert Shift:=xlDown
     Sheets("Paper").Range("A" & M1).Value = Cr3
     Sheets("Paper").Range("A" & M1).Font.ColorIndex = xlColorIndexAutomatic
     End If
     End If
   
     If M2 = 3 Then
     Range("O3").FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P3").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("Q3").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)),"""")"
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     ElseIf M2 = 4 Then
     Range("O3").FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P3").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("Q3").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)),"""")"
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     ElseIf M2 > 4 Then
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     End If
     For i = M2 To Lr2
      Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
     Sheets("Paper").Activate
     Sheets("Paper").Range("A" & M1).Select
     Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
    Application.EnableEvents = True
   End If
  End If
End Sub
 
Upvote 0
maabadi said:
I find One Way. First Move New Customer Rows to Last 4 rows at Work & Paper Sheets
Second Hide Both at Both Sheets.
Then Try these codes:
VBA Code: 
Private Sub Worksheet_Change(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
On Error Resume Next
Lr1 = Range("I" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
Lr2 = Range("N" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
If Intersect(Target, Union(Range("I3:I" & Lr1 + Target.Rows.Count - 1), Range("N3:N" & Lr2 + Target.Rows.Count - 1))) Is Nothing Then Exit Sub
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
If Not Intersect(Target, Range("I3:I" & Lr1 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("I" & Target.Row - 1), Sheets("Work").Range("A1:A" & Lr3), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum2
End If
For i = M1 + 2 To Lr3
If Sheets("work").Range("A" & i).Interior.Color = 4697456 Then
M1 = i
GoTo Resum2
End If
Next i
Resum2:
M2 = Application.WorksheetFunction.Match(Range("I" & Target.Row), Sheets("Work").Range("A1:A" & Lr3), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum7
       End If
       Next i
End If
Resum7:
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Work").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Work").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr1 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
For i = Target.Row To Lr1 - M1
  If i = 3 Then
     Range("J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i).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" & i).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 i > 3 Then
     Range("J" & i - 1 & ":J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i - 1 & ":K" & i).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" & i - 1 & ":L" & i).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
If i = Lr1 - Target.Rows.Count Then GoTo Resum5
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
Resum5:
M2 = Application.WorksheetFunction.Match("New Customer", Range("I1:I" & Lr1), 0)
Range("J" & M2 & ":L" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

If Not Intersect(Target, Range("N3:N" & Lr2 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("N" & Target.Row - 1), Sheets("Paper").Range("A1:A" & Lr4), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum3
End If
For i = M1 + 2 To Lr4
If Sheets("Paper").Range("A" & i).Interior.Color = 12874308 Then
M1 = i
GoTo Resum3
End If
Next i
Resum3:
M2 = Application.WorksheetFunction.Match(Range("N" & Target.Row), Sheets("Paper").Range("A1:A" & Lr4), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum8
       End If
       Next i
End If
Resum8:
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Paper").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Paper").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr2 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
For i = Target.Row To Lr2 - M1
  If i = 3 Then
     Range("O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i).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" & i).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 i > 3 Then
     Range("O" & i - 1 & ":O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i - 1 & ":P" & i).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" & i - 1 & ":Q" & i).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
If i = Lr2 - Target.Rows.Count + 1 Then GoTo Resum6
    Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
Resum6:
M2 = Application.WorksheetFunction.Match("New Customer", Range("N1:N" & Lr2), 0)
Range("O" & M2 & ":Q" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

Application.EnableEvents = True
End Sub

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, M3 As Long
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
     If Lr3 = 1 And Sheets("Work").Range("A1").Value = "" Then GoTo Resum3
     For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M3 = i + 1
       GoTo Resum3
       End If
       Next i
Resum3:
     If Lr3 = 1 And Sheets("Work").Range("A1").Value = "" Then M3 = 1
     Sheets("Dashboard").Range("I" & Lr1).Value = Cr3
     Worksheets("Dashboard").Sort.SortFields.Clear
     Range("I2:I" & Lr1).Sort Key1:=Range("I2"), Header:=xlYes, Order1:=xlAscending
     M2 = Application.WorksheetFunction.Match(Cr3, Sheets("Dashboard").Range("I1:I" & Lr1), 0)
     M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & M2 + 1).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
     Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
     Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Work").Range("A" & Rows.Count - 7)
     If M1 = 0 Then M1 = M3
     Sheets("Work").Range("A" & Rows.Count - 7 & ":G" & Rows.Count - 4).Copy
     Sheets("Work").Range("A" & M1 & ":G" & M1).Insert Shift:=xlDown
     Sheets("Work").Range("A" & M1).Value = Cr3
     Sheets("Work").Range("A" & M1).Font.ColorIndex = xlColorIndexAutomatic
     End If
     End If
 
  If M2 = 3 Then
     Range("J3").FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K3").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("L3").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)),"""")"
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  ElseIf M2 = 4 Then
     Range("J3").FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K3").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("L3").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)),"""")"
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  ElseIf M2 > 4 Then
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  End If
   For i = M2 To Lr1
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
     Sheets("Work").Activate
     Sheets("Work").Range("A" & M1).Select
     Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
     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
     If Lr4 = 1 And Sheets("Paper").Range("A1").Value = "" Then GoTo Resum4
     For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M3 = i + 1
       GoTo Resum4
       End If
       Next i
Resum4:
     If Lr4 = 1 And Sheets("Paper").Range("A1").Value = "" Then M3 = 1
     Sheets("Dashboard").Range("N" & Lr2).Value = Cr3
     Worksheets("Dashboard").Sort.SortFields.Clear
     Range("N2:N" & Lr2).Sort Key1:=Range("N2"), Header:=xlYes, Order1:=xlAscending
     M2 = Application.WorksheetFunction.Match(Cr3, Sheets("Dashboard").Range("N1:N" & Lr2), 0)
     M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & M2 + 1).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
     Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
     Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Paper").Range("A" & Rows.Count - 7)
     If M1 = 0 Then M1 = M3
     Sheets("Paper").Range("A" & Rows.Count - 7 & ":G" & Rows.Count - 4).Copy
     Sheets("Paper").Range("A" & M1 & ":G" & M1).Insert Shift:=xlDown
     Sheets("Paper").Range("A" & M1).Value = Cr3
     Sheets("Paper").Range("A" & M1).Font.ColorIndex = xlColorIndexAutomatic
     End If
     End If
 
     If M2 = 3 Then
     Range("O3").FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P3").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("Q3").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)),"""")"
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     ElseIf M2 = 4 Then
     Range("O3").FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P3").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("Q3").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)),"""")"
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     ElseIf M2 > 4 Then
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     End If
     For i = M2 To Lr2
      Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
     Sheets("Paper").Activate
     Sheets("Paper").Range("A" & M1).Select
     Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
    Application.EnableEvents = True
   End If
  End If
End Sub
Click to expand...
yes. this may correct but before than, show 2 problem :( (sorry for this)
1. again make hyperlink for new customer in dashboard
2. show error unmerged cells and ask for continue or cancel
this codes i use for work and paper
for work
VBA Code: 
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 = "Microsoft Parsi"
                .Font.Size = 14
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
     End With
  Next i
  Application.EnableEvents = True
End Sub
for paper (i set this code based on work code you send in other post that's about fill number in gray row and insert with that amount)
Code: 
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" & 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
  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 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 = "Microsoft Parsi"
                .Font.Size = 14
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
     End With
  Next i
  Application.EnableEvents = True
End Sub
and scroll down change range to going end excel rows, before than just for active cells, this is not make problem?
 
Upvote 0
For Work Sheet Use this Code. & Use Same Code For Paper Sheet Also (Change Sheet Name & Lr3 to Lr4)
VBA Code: 
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
  Application.DisplayAlerts = False
  If Target.Interior.Color = 14277081 Then
  If Target.Value <> "" Then
  Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
  K = Rows.Count - 3 - Target.Value
  Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Work").Range("A" & K)
  Rows(Target.Row & ":" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
  Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
  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 = "Microsoft Parsi"
                .Font.Size = 14
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
     End With
  Next i
  Application.DisplayAlerts = True
  Application.EnableEvents = True
End Sub
For Hyperlink First Select New Customer & Remove Hyperlink Then Try This code:
VBA Code: 
Private Sub Worksheet_Change(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
On Error Resume Next
Lr1 = Range("I" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
Lr2 = Range("N" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
If Intersect(Target, Union(Range("I3:I" & Lr1 + Target.Rows.Count - 1), Range("N3:N" & Lr2 + Target.Rows.Count - 1))) Is Nothing Then Exit Sub
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
If Not Intersect(Target, Range("I3:I" & Lr1 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("I" & Target.Row - 1), Sheets("Work").Range("A1:A" & Lr3), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum2
End If
For i = M1 + 2 To Lr3
If Sheets("work").Range("A" & i).Interior.Color = 4697456 Then
M1 = i
GoTo Resum2
End If
Next i
Resum2:
M2 = Application.WorksheetFunction.Match(Range("I" & Target.Row), Sheets("Work").Range("A1:A" & Lr3), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum7
       End If
       Next i
End If
Resum7:
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Work").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Work").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr1 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
If Lr1 = 3 Then GoTo Resum5
For i = Target.Row To Lr1 - M1
  If i = 3 Then
     Range("J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i).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" & i).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 i > 3 Then
     Range("J" & i - 1 & ":J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i - 1 & ":K" & i).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" & i - 1 & ":L" & i).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
If i = Lr1 - Target.Rows.Count Then GoTo Resum5
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
Resum5:
M2 = Application.WorksheetFunction.Match("New Customer", Range("I1:I" & Lr1), 0)
Range("J" & M2 & ":L" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

If Not Intersect(Target, Range("N3:N" & Lr2 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("N" & Target.Row - 1), Sheets("Paper").Range("A1:A" & Lr4), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum3
End If
For i = M1 + 2 To Lr4
If Sheets("Paper").Range("A" & i).Interior.Color = 12874308 Then
M1 = i
GoTo Resum3
End If
Next i
Resum3:
M2 = Application.WorksheetFunction.Match(Range("N" & Target.Row), Sheets("Paper").Range("A1:A" & Lr4), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum8
       End If
       Next i
End If
Resum8:
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Paper").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Paper").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr2 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
If Lr2 = 3 Then GoTo Resum6
For i = Target.Row To Lr2 - M1
  If i = 3 Then
     Range("O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i).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" & i).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 i > 3 Then
     Range("O" & i - 1 & ":O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i - 1 & ":P" & i).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" & i - 1 & ":Q" & i).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
If i = Lr2 - Target.Rows.Count + 1 Then GoTo Resum6
    Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
Resum6:
M2 = Application.WorksheetFunction.Match("New Customer", Range("N1:N" & Lr2), 0)
Range("O" & M2 & ":Q" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

Application.EnableEvents = True
End Sub

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, M3 As Long
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
     If Lr3 = 1 And Sheets("Work").Range("A1").Value = "" Then GoTo Resum3
     For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M3 = i + 1
       GoTo Resum3
       End If
       Next i
Resum3:
     If Lr3 = 1 And Sheets("Work").Range("A1").Value = "" Then M3 = 1
     Sheets("Dashboard").Range("I" & Lr1).Value = Cr3
     Worksheets("Dashboard").Sort.SortFields.Clear
     Range("I2:I" & Lr1).Sort Key1:=Range("I2"), Header:=xlYes, Order1:=xlAscending
     M2 = Application.WorksheetFunction.Match(Cr3, Sheets("Dashboard").Range("I1:I" & Lr1), 0)
     M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & M2 + 1).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
     Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
     Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Work").Range("A" & Rows.Count - 7)
     If M1 = 0 Then M1 = M3
     Sheets("Work").Range("A" & Rows.Count - 7 & ":G" & Rows.Count - 4).Copy
     Sheets("Work").Range("A" & M1 & ":G" & M1).Insert Shift:=xlDown
     Sheets("Work").Range("A" & M1).Value = Cr3
     Sheets("Work").Range("A" & M1).Font.ColorIndex = xlColorIndexAutomatic
     End If
     End If
   
  If M2 = 3 Then
     Range("J3").FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K3").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("L3").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)),"""")"
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  ElseIf M2 = 4 Then
     Range("J3").FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K3").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("L3").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)),"""")"
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  ElseIf M2 > 4 Then
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  End If
   For i = M2 To Lr1
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
     Sheets("Work").Activate
     Sheets("Work").Range("A" & M1).Select
     Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
     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
     If Lr4 = 1 And Sheets("Paper").Range("A1").Value = "" Then GoTo Resum4
     For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M3 = i + 1
       GoTo Resum4
       End If
       Next i
Resum4:
     If Lr4 = 1 And Sheets("Paper").Range("A1").Value = "" Then M3 = 1
     Sheets("Dashboard").Range("N" & Lr2).Value = Cr3
     Worksheets("Dashboard").Sort.SortFields.Clear
     Range("N2:N" & Lr2).Sort Key1:=Range("N2"), Header:=xlYes, Order1:=xlAscending
     M2 = Application.WorksheetFunction.Match(Cr3, Sheets("Dashboard").Range("N1:N" & Lr2), 0)
     M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & M2 + 1).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
     Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
     Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Paper").Range("A" & Rows.Count - 7)
     If M1 = 0 Then M1 = M3
     Sheets("Paper").Range("A" & Rows.Count - 7 & ":G" & Rows.Count - 4).Copy
     Sheets("Paper").Range("A" & M1 & ":G" & M1).Insert Shift:=xlDown
     Sheets("Paper").Range("A" & M1).Value = Cr3
     Sheets("Paper").Range("A" & M1).Font.ColorIndex = xlColorIndexAutomatic
     End If
     End If
   
     If M2 = 3 Then
     Range("O3").FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P3").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("Q3").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)),"""")"
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     ElseIf M2 = 4 Then
     Range("O3").FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P3").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("Q3").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)),"""")"
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     ElseIf M2 > 4 Then
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     End If
     For i = M2 To Lr2
      Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
     Sheets("Paper").Activate
     Sheets("Paper").Range("A" & M1).Select
     Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
    Application.EnableEvents = True
   End If
  End If
End Sub
 
Upvote 0
maabadi said:
For Work Sheet Use this Code. & Use Same Code For Paper Sheet Also (Change Sheet Name & Lr3 to Lr4)
VBA Code: 
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
  Application.DisplayAlerts = False
  If Target.Interior.Color = 14277081 Then
  If Target.Value <> "" Then
  Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
  K = Rows.Count - 3 - Target.Value
  Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Work").Range("A" & K)
  Rows(Target.Row & ":" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
  Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
  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 = "Microsoft Parsi"
                .Font.Size = 14
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
     End With
  Next i
  Application.DisplayAlerts = True
  Application.EnableEvents = True
End Sub
For Hyperlink First Select New Customer & Remove Hyperlink Then Try This code:
VBA Code: 
Private Sub Worksheet_Change(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
On Error Resume Next
Lr1 = Range("I" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
Lr2 = Range("N" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
If Intersect(Target, Union(Range("I3:I" & Lr1 + Target.Rows.Count - 1), Range("N3:N" & Lr2 + Target.Rows.Count - 1))) Is Nothing Then Exit Sub
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
If Not Intersect(Target, Range("I3:I" & Lr1 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("I" & Target.Row - 1), Sheets("Work").Range("A1:A" & Lr3), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum2
End If
For i = M1 + 2 To Lr3
If Sheets("work").Range("A" & i).Interior.Color = 4697456 Then
M1 = i
GoTo Resum2
End If
Next i
Resum2:
M2 = Application.WorksheetFunction.Match(Range("I" & Target.Row), Sheets("Work").Range("A1:A" & Lr3), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum7
       End If
       Next i
End If
Resum7:
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Work").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Work").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr1 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
If Lr1 = 3 Then GoTo Resum5
For i = Target.Row To Lr1 - M1
  If i = 3 Then
     Range("J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i).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" & i).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 i > 3 Then
     Range("J" & i - 1 & ":J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i - 1 & ":K" & i).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" & i - 1 & ":L" & i).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
If i = Lr1 - Target.Rows.Count Then GoTo Resum5
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
Resum5:
M2 = Application.WorksheetFunction.Match("New Customer", Range("I1:I" & Lr1), 0)
Range("J" & M2 & ":L" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

If Not Intersect(Target, Range("N3:N" & Lr2 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("N" & Target.Row - 1), Sheets("Paper").Range("A1:A" & Lr4), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum3
End If
For i = M1 + 2 To Lr4
If Sheets("Paper").Range("A" & i).Interior.Color = 12874308 Then
M1 = i
GoTo Resum3
End If
Next i
Resum3:
M2 = Application.WorksheetFunction.Match(Range("N" & Target.Row), Sheets("Paper").Range("A1:A" & Lr4), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum8
       End If
       Next i
End If
Resum8:
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Paper").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Paper").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr2 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
If Lr2 = 3 Then GoTo Resum6
For i = Target.Row To Lr2 - M1
  If i = 3 Then
     Range("O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i).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" & i).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 i > 3 Then
     Range("O" & i - 1 & ":O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i - 1 & ":P" & i).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" & i - 1 & ":Q" & i).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
If i = Lr2 - Target.Rows.Count + 1 Then GoTo Resum6
    Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
Resum6:
M2 = Application.WorksheetFunction.Match("New Customer", Range("N1:N" & Lr2), 0)
Range("O" & M2 & ":Q" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

Application.EnableEvents = True
End Sub

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, M3 As Long
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
     If Lr3 = 1 And Sheets("Work").Range("A1").Value = "" Then GoTo Resum3
     For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M3 = i + 1
       GoTo Resum3
       End If
       Next i
Resum3:
     If Lr3 = 1 And Sheets("Work").Range("A1").Value = "" Then M3 = 1
     Sheets("Dashboard").Range("I" & Lr1).Value = Cr3
     Worksheets("Dashboard").Sort.SortFields.Clear
     Range("I2:I" & Lr1).Sort Key1:=Range("I2"), Header:=xlYes, Order1:=xlAscending
     M2 = Application.WorksheetFunction.Match(Cr3, Sheets("Dashboard").Range("I1:I" & Lr1), 0)
     M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & M2 + 1).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
     Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
     Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Work").Range("A" & Rows.Count - 7)
     If M1 = 0 Then M1 = M3
     Sheets("Work").Range("A" & Rows.Count - 7 & ":G" & Rows.Count - 4).Copy
     Sheets("Work").Range("A" & M1 & ":G" & M1).Insert Shift:=xlDown
     Sheets("Work").Range("A" & M1).Value = Cr3
     Sheets("Work").Range("A" & M1).Font.ColorIndex = xlColorIndexAutomatic
     End If
     End If
 
  If M2 = 3 Then
     Range("J3").FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K3").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("L3").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)),"""")"
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  ElseIf M2 = 4 Then
     Range("J3").FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K3").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("L3").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)),"""")"
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  ElseIf M2 > 4 Then
     Range("J3:L3").AutoFill Destination:=Range("J3:L" & Lr1)
  End If
   For i = M2 To Lr1
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
     Sheets("Work").Activate
     Sheets("Work").Range("A" & M1).Select
     Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
     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
     If Lr4 = 1 And Sheets("Paper").Range("A1").Value = "" Then GoTo Resum4
     For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M3 = i + 1
       GoTo Resum4
       End If
       Next i
Resum4:
     If Lr4 = 1 And Sheets("Paper").Range("A1").Value = "" Then M3 = 1
     Sheets("Dashboard").Range("N" & Lr2).Value = Cr3
     Worksheets("Dashboard").Sort.SortFields.Clear
     Range("N2:N" & Lr2).Sort Key1:=Range("N2"), Header:=xlYes, Order1:=xlAscending
     M2 = Application.WorksheetFunction.Match(Cr3, Sheets("Dashboard").Range("N1:N" & Lr2), 0)
     M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("N" & M2 + 1).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
     Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
     Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count).Cut Sheets("Paper").Range("A" & Rows.Count - 7)
     If M1 = 0 Then M1 = M3
     Sheets("Paper").Range("A" & Rows.Count - 7 & ":G" & Rows.Count - 4).Copy
     Sheets("Paper").Range("A" & M1 & ":G" & M1).Insert Shift:=xlDown
     Sheets("Paper").Range("A" & M1).Value = Cr3
     Sheets("Paper").Range("A" & M1).Font.ColorIndex = xlColorIndexAutomatic
     End If
     End If
 
     If M2 = 3 Then
     Range("O3").FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P3").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("Q3").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)),"""")"
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     ElseIf M2 = 4 Then
     Range("O3").FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P3").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("Q3").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)),"""")"
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     ElseIf M2 > 4 Then
     Range("O3:Q3").AutoFill Destination:=Range("O3:Q" & Lr2)
     End If
     For i = M2 To Lr2
      Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
     Sheets("Paper").Activate
     Sheets("Paper").Range("A" & M1).Select
     Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
    Application.EnableEvents = True
   End If
  End If
End Sub
Click to expand...
Again create hyperlink and copy/paste in work sheet doesn't work
 

Attachments

  • image_2021-05-09_123147.png
    image_2021-05-09_123147.png
    3.4 KB · Views: 3
Upvote 0
For Hyperlink Try this:
VBA Code: 
Private Sub Worksheet_Change(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
On Error Resume Next
Lr1 = Range("I" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
Lr2 = Range("N" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
If Intersect(Target, Union(Range("I3:I" & Lr1 + Target.Rows.Count - 1), Range("N3:N" & Lr2 + Target.Rows.Count - 1))) Is Nothing Then Exit Sub
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
If Not Intersect(Target, Range("I3:I" & Lr1 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("I" & Target.Row - 1), Sheets("Work").Range("A1:A" & Lr3), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum2
End If
For i = M1 + 2 To Lr3
If Sheets("work").Range("A" & i).Interior.Color = 4697456 Then
M1 = i
GoTo Resum2
End If
Next i
Resum2:
M2 = Application.WorksheetFunction.Match(Range("I" & Target.Row), Sheets("Work").Range("A1:A" & Lr3), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum7
       End If
       Next i
End If
Resum7:
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Work").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Work").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr1 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
If Lr1 = 3 Then GoTo Resum5
For i = Target.Row To Lr1 - M1
  If i = 3 Then
     Range("J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i).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" & i).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 i > 3 Then
     Range("J" & i - 1 & ":J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i - 1 & ":K" & i).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" & i - 1 & ":L" & i).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
If i = Lr1 - Target.Rows.Count + 1 Then GoTo Resum5
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
Resum5:
M2 = Application.WorksheetFunction.Match("New Customer", Range("I1:I" & Lr1), 0)
Range("J" & M2 & ":L" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

If Not Intersect(Target, Range("N3:N" & Lr2 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("N" & Target.Row - 1), Sheets("Paper").Range("A1:A" & Lr4), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum3
End If
For i = M1 + 2 To Lr4
If Sheets("Paper").Range("A" & i).Interior.Color = 12874308 Then
M1 = i
GoTo Resum3
End If
Next i
Resum3:
M2 = Application.WorksheetFunction.Match(Range("N" & Target.Row), Sheets("Paper").Range("A1:A" & Lr4), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum8
       End If
       Next i
End If
Resum8:
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Paper").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Paper").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr2 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
If Lr2 = 3 Then GoTo Resum6
For i = Target.Row To Lr2 - M1
  If i = 3 Then
     Range("O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i).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" & i).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 i > 3 Then
     Range("O" & i - 1 & ":O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i - 1 & ":P" & i).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" & i - 1 & ":Q" & i).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
If i = Lr2 - Target.Rows.Count + 1 Then GoTo Resum6
    Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
Resum6:
M2 = Application.WorksheetFunction.Match("New Customer", Range("N1:N" & Lr2), 0)
Range("O" & M2 & ":Q" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

Application.EnableEvents = True
End Sub
For Copy & paste if you want Insert row, Yes you cannot, Because you have data at last row, but if only want copy & paste not Problem, I think.
If you want add rows, first add number to gray rows to add rows then copy paste values.
 
Upvote 0
maabadi said:
For Hyperlink Try this:
VBA Code: 
Private Sub Worksheet_Change(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
On Error Resume Next
Lr1 = Range("I" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
Lr2 = Range("N" & Rows.Count).End(xlUp).Row + Target.Rows.Count - 1
If Intersect(Target, Union(Range("I3:I" & Lr1 + Target.Rows.Count - 1), Range("N3:N" & Lr2 + Target.Rows.Count - 1))) Is Nothing Then Exit Sub
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row
Application.EnableEvents = False
If Not Intersect(Target, Range("I3:I" & Lr1 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("I" & Target.Row - 1), Sheets("Work").Range("A1:A" & Lr3), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum2
End If
For i = M1 + 2 To Lr3
If Sheets("work").Range("A" & i).Interior.Color = 4697456 Then
M1 = i
GoTo Resum2
End If
Next i
Resum2:
M2 = Application.WorksheetFunction.Match(Range("I" & Target.Row), Sheets("Work").Range("A1:A" & Lr3), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr3 + 2 To Lr3 + 40
      If Sheets("Work").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum7
       End If
       Next i
End If
Resum7:
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Work").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Work").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Work").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr1 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
If Lr1 = 3 Then GoTo Resum5
For i = Target.Row To Lr1 - M1
  If i = 3 Then
     Range("J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i).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" & i).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 i > 3 Then
     Range("J" & i - 1 & ":J" & i).FormulaR1C1 = "=IFERROR(INDEX(Work!C[-8],MATCH(R[1]C9,Work!C[-9],0)-2,0),"""")"
     Range("K" & i - 1 & ":K" & i).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" & i - 1 & ":L" & i).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
If i = Lr1 - Target.Rows.Count + 1 Then GoTo Resum5
    Cr1 = Application.WorksheetFunction.Match(Range("I" & i), Sheets("Work").Range("A1:A" & Lr3), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("I" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=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
Resum5:
M2 = Application.WorksheetFunction.Match("New Customer", Range("I1:I" & Lr1), 0)
Range("J" & M2 & ":L" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Work").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

If Not Intersect(Target, Range("N3:N" & Lr2 + Target.Rows.Count - 1)) Is Nothing Then
M1 = Application.WorksheetFunction.Match(Range("N" & Target.Row - 1), Sheets("Paper").Range("A1:A" & Lr4), 0)
If M1 = 0 Or Target.Row = 3 Then
M1 = 1
GoTo Resum3
End If
For i = M1 + 2 To Lr4
If Sheets("Paper").Range("A" & i).Interior.Color = 12874308 Then
M1 = i
GoTo Resum3
End If
Next i
Resum3:
M2 = Application.WorksheetFunction.Match(Range("N" & Target.Row), Sheets("Paper").Range("A1:A" & Lr4), 0) - 1
If M2 = 4 Then M1 = 1
If M2 = 0 Then
For i = Lr4 + 2 To Lr4 + 40
      If Sheets("Paper").Range("A" & i).Interior.Color = 14277081 Then
       M2 = i
       GoTo Resum8
       End If
       Next i
End If
Resum8:
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = False
Sheets("Paper").Rows(M1 & ":" & M2).Delete
M2 = Rows.Count - M2 + M1 - 4
Sheets("Paper").Range("A" & M2 & ":G" & M2 + 3).Cut Sheets("Paper").Range("A" & Rows.Count - 3 & ":G" & Rows.Count)
M1 = Target.Rows.Count
If Lr2 = Target.Row + Target.Rows.Count - 1 Then M1 = 0
If Lr2 = 3 Then GoTo Resum6
For i = Target.Row To Lr2 - M1
  If i = 3 Then
     Range("O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i).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" & i).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 i > 3 Then
     Range("O" & i - 1 & ":O" & i).FormulaR1C1 = "=IFERROR(INDEX(Paper!C[-13],MATCH(R[1]C14,Paper!C[-14],0)-2,0),"""")"
     Range("P" & i - 1 & ":P" & i).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" & i - 1 & ":Q" & i).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
If i = Lr2 - Target.Rows.Count + 1 Then GoTo Resum6
    Cr1 = Application.WorksheetFunction.Match(Range("N" & i), Sheets("Paper").Range("A1:A" & Lr4), 0)
     Cr1R = Range("A" & Cr1).Address
     Range("N" & i).Hyperlinks.Delete
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & i), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr1R, TextToDisplay:=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
Resum6:
M2 = Application.WorksheetFunction.Match("New Customer", Range("N1:N" & Lr2), 0)
Range("O" & M2 & ":Q" & M2 + Target.Rows.Count - 1).Delete Shift:=xlUp
Sheets("Paper").Rows(Rows.Count - 3 & ":" & Rows.Count).Hidden = True
End If

Application.EnableEvents = True
End Sub
For Copy & paste if you want Insert row, Yes you cannot, Because you have data at last row, but if only want copy & paste not Problem, I think.
If you want add rows, first add number to gray rows to add rows then copy paste values.
Click to expand...
not inputbox shows, and another thing, i think hidden this 4 rows make lots of problem, i just not seen this after last customer, sorry but i have a think, i colored all text to white and fill cells to white, another way when copy/paste doing this colored? but if can fix with the code before this function, because scroll down is not find last active cell (going till excel rows end), im so sorry, i make trouble for you, sorry :(
 
Upvote 0
Maybe you run code one time uncomplete.
Add this code to immediate window and Press Enter Then Test code again.
VBA Code: 
Application.EnableEvents = True
For others all work on Test file completely fine. I test it multiple time & Conditions.
I Upload Test file for you Tommorrow.
 
Upvote 0
maabadi said:
Maybe you run code one time uncomplete.
Add this code to immediate window and Press Enter Then Test code again.
VBA Code: 
Application.EnableEvents = True
For others all work on Test file completely fine. I test it multiple time & Conditions.
I Upload Test file for you Tommorrow.
Click to expand...
i wait, and Thank You, sorry again, you made my works very easy and ideal and very very useful
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
VBA - add formula to cell when created
Replies
2
Views
312
Golaidron
G
T
  • Solved
Adding additional text to a value pulled from another sheet
Replies
8
Views
152
Snakehips
Snakehips
T
  • Solved
MATCH function
2
Replies
14
Views
200
Fluff
Fluff
I
  • Question
Copy worksheet but the new worksheet to omit some items
2
Replies
11
Views
471
ipbr21054
I
szita2000
  • Question
Index Match Match from a named table to a range
Replies
1
Views
367
Alex Blakenburg
A

Forum statistics

Threads
1,215,614
Messages
6,125,848
Members
449,266
Latest member
davinroach

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