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
For Add 4 specific Row & new Customer Name, Try this:
VBA Code: 
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 Not Intersect(Target, Range("I" & Lr1)) Is Nothing Then
   If Target.Count = 1 Then
    Application.EnableEvents = False
     Range("I" & Lr1 & ":M" & Lr1).Insert Shift:=xlDown
     M1 = Application.WorksheetFunction.Match(Range("I" & Lr1 - 1).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
     For i = M1 + 2 To Lr3
     If Sheets("Work").Range("A" & i).Interior.Color = 4697456 Then
     If Sheets("Work").Range("A" & i).Value = "New Customer" Then
     'Range("I" & Lr1 & ":M" & Lr1).Delete Shift:=xlUp
     Cr3 = Application.InputBox(prompt:="Please Input New Customer Name", Type:=2)
     If Cr3 = False Then
     Range("I" & Lr1 & ":M" & Lr1).Delete Shift:=xlUp
     Application.EnableEvents = True
     Exit Sub
     Else
     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
     Range("I" & Lr1).Value = Sheets("Work").Range("A" & i).Value
     Else
     Range("I" & Lr1).Value = Sheets("Work").Range("A" & i).Value
     End If
     Cr1 = i
     GoTo Resum1
     End If
     Next i
Resum1:
     
     Cr1R = Range("A" & Cr1).Address
     Range("J" & Lr1 - 2 & ":L" & Lr1 - 2).AutoFill Destination:=Range("J" & Lr1 - 2 & ":L" & Lr1)
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & Lr1), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=Range("I" & Lr1).Value
     Application.EnableEvents = True
   End If
  End If
    If Not Intersect(Target, Range("N" & Lr2)) Is Nothing Then
   If Target.Count = 1 Then
    Application.EnableEvents = False
     Range("N" & Lr2 & ":Q" & Lr2).Insert Shift:=xlDown
     M2 = Application.WorksheetFunction.Match(Range("N" & Lr2 - 1).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
     For i = M2 + 2 To Lr4
     If Sheets("Paper").Range("A" & i).Interior.Color = 12874308 Then
     If Sheets("Paper").Range("A" & i).Value = "New Customer" Then
     Cr3 = Application.InputBox(prompt:="Please Input New Customer Name", Type:=2)
     If Cr3 = False Then
     Range("N" & Lr2 & ":Q" & Lr2).Delete Shift:=xlUp
     Application.EnableEvents = True
     Exit Sub
     Else
     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
     Range("N" & Lr2).Value = Sheets("Paper").Range("A" & i).Value
     Else
     Range("N" & Lr2).Value = Sheets("Paper").Range("A" & i).Value
     End If
     Cr2 = i
     GoTo Resum2
     End If
     Next i
Resum2:
      Cr2R = Range("A" & Cr2).Address
     Range("O" & Lr2 - 2 & ":Q" & Lr2 - 2).AutoFill Destination:=Range("O" & Lr2 - 2 & ":Q" & Lr2)
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & Lr2), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr2R, TextToDisplay:=Range("N" & Lr2).Value
    Application.EnableEvents = True
   End If
  End If
End Sub
 
Upvote 0

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
maabadi said:
You should insert first two customer, because when we Insert row, formul at the last row changed & thus I take formula from 2 row before
Click to expand...
i understood, i want delete all my customer and select new customer at first until end customer for same hyperlink method you written
 
Upvote 0
maabadi said:
For Add 4 specific Row & new Customer Name, Try this:
VBA Code: 
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 Not Intersect(Target, Range("I" & Lr1)) Is Nothing Then
   If Target.Count = 1 Then
    Application.EnableEvents = False
     Range("I" & Lr1 & ":M" & Lr1).Insert Shift:=xlDown
     M1 = Application.WorksheetFunction.Match(Range("I" & Lr1 - 1).Value, Sheets("Work").Range("A1:A" & Lr3), 0)
     For i = M1 + 2 To Lr3
     If Sheets("Work").Range("A" & i).Interior.Color = 4697456 Then
     If Sheets("Work").Range("A" & i).Value = "New Customer" Then
     'Range("I" & Lr1 & ":M" & Lr1).Delete Shift:=xlUp
     Cr3 = Application.InputBox(prompt:="Please Input New Customer Name", Type:=2)
     If Cr3 = False Then
     Range("I" & Lr1 & ":M" & Lr1).Delete Shift:=xlUp
     Application.EnableEvents = True
     Exit Sub
     Else
     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
     Range("I" & Lr1).Value = Sheets("Work").Range("A" & i).Value
     Else
     Range("I" & Lr1).Value = Sheets("Work").Range("A" & i).Value
     End If
     Cr1 = i
     GoTo Resum1
     End If
     Next i
Resum1:
    
     Cr1R = Range("A" & Cr1).Address
     Range("J" & Lr1 - 2 & ":L" & Lr1 - 2).AutoFill Destination:=Range("J" & Lr1 - 2 & ":L" & Lr1)
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("I" & Lr1), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & Cr1R, TextToDisplay:=Range("I" & Lr1).Value
     Application.EnableEvents = True
   End If
  End If
    If Not Intersect(Target, Range("N" & Lr2)) Is Nothing Then
   If Target.Count = 1 Then
    Application.EnableEvents = False
     Range("N" & Lr2 & ":Q" & Lr2).Insert Shift:=xlDown
     M2 = Application.WorksheetFunction.Match(Range("N" & Lr2 - 1).Value, Sheets("Paper").Range("A1:A" & Lr4), 0)
     For i = M2 + 2 To Lr4
     If Sheets("Paper").Range("A" & i).Interior.Color = 12874308 Then
     If Sheets("Paper").Range("A" & i).Value = "New Customer" Then
     Cr3 = Application.InputBox(prompt:="Please Input New Customer Name", Type:=2)
     If Cr3 = False Then
     Range("N" & Lr2 & ":Q" & Lr2).Delete Shift:=xlUp
     Application.EnableEvents = True
     Exit Sub
     Else
     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
     Range("N" & Lr2).Value = Sheets("Paper").Range("A" & i).Value
     Else
     Range("N" & Lr2).Value = Sheets("Paper").Range("A" & i).Value
     End If
     Cr2 = i
     GoTo Resum2
     End If
     Next i
Resum2:
      Cr2R = Range("A" & Cr2).Address
     Range("O" & Lr2 - 2 & ":Q" & Lr2 - 2).AutoFill Destination:=Range("O" & Lr2 - 2 & ":Q" & Lr2)
     Sheets("Dashboard").Hyperlinks.Add Anchor:=Range("N" & Lr2), Address:="", SubAddress:="'" & Sheets("Paper").Name & "'!" & Cr2R, TextToDisplay:=Range("N" & Lr2).Value
    Application.EnableEvents = True
   End If
  End If
End Sub
Click to expand...
no that is not work, and not give a name after that copy paste, and not doing copy paste, work like before
 
Upvote 0
Please test it also on your updated file. It works completely fine within it.
AND what rows copy & paste if it do wrong? I set it to copy New Customer Row until 3 row below (should be Last Grey row).
 
Upvote 0
maabadi said:
Please test it also on your updated file. It works completely fine within it.
AND what rows copy & paste if it do wrong? I set it to copy New Customer Row until 3 row below (should be Last Grey row).
Click to expand...
you set correct, but not doing anything, see this 3 photos may help you, but for range can changeable, anyway just find this 4 rows ? this 4 rows should always at the end of last customer
and i say, i insert a name in empty cell when select enter, create another empty cell below, and even copy paste in work and paper
 

Attachments

  • Screenshot 2021-04-07 154415.png
    Screenshot 2021-04-07 154415.png
    3.1 KB · Views: 5
  • Screenshot 2021-04-07 154517.png
    Screenshot 2021-04-07 154517.png
    6.8 KB · Views: 6
  • Screenshot 2021-04-07 154428.png
    Screenshot 2021-04-07 154428.png
    7.2 KB · Views: 5
Upvote 0
maabadi said:
This is your files with macro I added to it, Do all thing that you want.
Book1.xlsm
Click to expand...
Yes this is correct and perfect work and doing all function i want, but when i insert this code in the file in my main workbook, not doing this function, what is problem? in work and paper i have another code to do, that is cause of this? or i have another sheet except 3 sheet you see...
plus, i think this cause, i have more customer in list in sheet dashboard of my workbook, i delete all customer list and please say what am i do at start that can code work correctly? and in work and paper i delete all customer and insert again?
what you do that link Customer A? generally you think i have dashboard with empty data, what am i do with this?
 
Last edited:
Upvote 0
Another sheets isn't problem.
Another code, if it's worksheet change event also, maybe.
1. Take backup
2. Delete customer names except 2 first for each sheet.
2. Then Test code.
 
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
293
Golaidron
G
I
  • Question
Copy worksheet but the new worksheet to omit some items
2
Replies
11
Views
434
ipbr21054
I
szita2000
  • Question
Index Match Match from a named table to a range
Replies
1
Views
310
Alex Blakenburg
A
B
  • Question
Copy formula into a cell using vba
2
Replies
11
Views
435
BobtBuilder
B
G
  • Solved
Extract the cells that contains alphanumeric string from the column
Replies
6
Views
366
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,214,991
Messages
6,122,628
Members
449,095
Latest member
bsb1122

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