Trouble adding rows with code

[al97233]

Awhile back Val was kind enough to write the following code for me which has worked very well up till now.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Column = 3 And Target.Row = Me.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row - 2 And Target.Count = 1 And IsEmpty(Target.Value) = False Then
        Application.EnableEvents = False
        
        Me.Range("A" & Target.Row + 1).EntireRow.Insert
        
        With Me
            .Range("A9:D9").Copy
            .Range("A" & Target.Row + 1 & ":D" & Target.Row + 1).PasteSpecial Paste:=xlPasteFormats
            .Range("D" & Target.Row + 1).Formula = "=A" & Target.Row + 1 & " * C" & Target.Row + 1
            .Range("A" & Target.Row + 1).Select
        End With
        
        Application.CutCopyMode = False
        
    End If
    Application.EnableEvents = True

the problem I am having is that I now need to insert several rows into the work sheet and when I do the code no longer works properly. Unfortunately I do not have the knowledge to know how to revise this code to keep it working properly. Another problem I have is I would like to lock most of the cells and protect the work sheet so that I could tab through the appropriate cells rather than have to click through them with a mouse.

Any help with this would be greatly appreciated.

 

[Yongle]

First of all, let's get the code to insert rows correctly

Test this in a copy of your workbook
- user is asked to input the number of rows to be inserted

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Column = 3 And Target.Row = Me.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row - 2 And Target.Count = 1 And IsEmpty(Target.Value) = False Then
        Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        Dim r As Long, rCount As Double
        rCount = Application.InputBox("How many rows to insert?", "Insert Rows", 1, , , , , 1)
        rCount = WorksheetFunction.Max(rCount, 1)                   'insert a minimum of 1 row
        
            For r = 1 To rCount
                Range("A" & Target.Row + 1).EntireRow.Insert
                Range("A9:D9").Copy
                Range("A" & Target.Row + 1 & ":D" & Target.Row + 1).PasteSpecial Paste:=xlPasteFormats
                Range("D" & Target.Row + 1).formula = "=A" & Target.Row + 1 & " * C" & Target.Row + 1
                Range("A" & Target.Row + 1).Select
                Application.CutCopyMode = False
            Next r
        
        Application.Calculation = xlCalculationAutomatic
        Application.EnableEvents = True
    End If
   
End Sub

I would like to lock most of the cells and protect the work sheet so that I could tab through the appropriate cells rather than have to click through them with a mouse.

Which cells should be locked?

 

[al97233]

Yongle,

Thank you for the help but I think I have not made myself clear. What I am trying to do is insert rows above row #3 so that i can insert a company name and some other information. The code you sent me works great but after inserting it if I attempt to insert a row the code doesn't work properly. below is a sample of the workbook.

Book1
	A	B	C	D
1	Rows are added automatically. In order for a row to be added you must enter a number into the "Sell" column. If you would like to add a blank row just enter "0" into that cell and tab out.
2
3			Sales Person:	Al Dennis
4	Customer:		Date:
5	Job Name:		Phone #:
6	Attn:		Lead Time:
7	Note:	Use tab key only below this line, do not use mouse (except first cell)
8	Qty	Description	Sell	Extended
9				$0.00
10
11			Total:	$0.00
12
13
14
15
16
Sheet1

Cell Formulas
Range	Formula
D9	=A9 * C9
D11	=SUM(D9:D10)

 

[Fluff]

How about

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Fnd As Range
   If Target.Column = 3 And Target.Row = Me.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row - 2 And Target.Count = 1 And IsEmpty(Target.Value) = False Then
      Application.EnableEvents = False
   
      Me.Range("A" & Target.Row + 1).EntireRow.Insert
   
      With Me
         Set Fnd = .Range("A:A").Find("Qty", , , xlWhole, , , False, , False)
         If Not Fnd Is Nothing Then
            Fnd.Offset(1).Resize(, 4).Copy
            .Range("A" & Target.Row + 1).Resize(, 4).PasteSpecial paste:=xlPasteFormats
            .Range("D" & Target.Row + 1).FormulaR1C1 = "=rc1*rc3"
            .Range("A" & Target.Row + 1).Select
         End If
      End With
      
      Application.CutCopyMode = False
      
   End If
   Application.EnableEvents = True
   End Sub

 

[al97233]

This may be a better view.
Excel 2016 (Windows) 64 bit
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]

A​

[/th][th]

B​

[/th][th]

C​

[/th][th]

D​

[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

1​

[/td][td]Rows are added automatically. In order for a row to be added you must enter a number into the "Sell" column.
If you would like to add a blank row just enter "0" into that cell and tab out.[/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

2​

[/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

3​

[/td][td]

​

[/td][td][/td][td]

Sales Person:​

[/td][td]Al Dennis[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

4​

[/td][td]

Customer:​

[/td][td][/td][td]

Date:​

[/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

5​

[/td][td]

Job Name:​

[/td][td][/td][td]

Phone #:​

[/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

6​

[/td][td]

Attn:​

[/td][td][/td][td]

Lead Time:​

[/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

7​

[/td][td]

Note:​

[/td][td]Use tab key only below this line, do not use mouse (except first cell)[/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

8​

[/td][td]

Qty​

[/td][td]Description[/td][td]

Sell​

[/td][td]

Extended​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

9​

[/td][td]

​

[/td][td][/td][td][/td][td]

$0.00​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

10​

[/td][td]

​

[/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

11​

[/td][td]

​

[/td][td][/td][td]

Total:​

[/td][td]

$0.00​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

12​

[/td][td]

​

[/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

13​

[/td][td]

​

[/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

14​

[/td][td]

​

[/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

15​

[/td][td]

​

[/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

16​

[/td][td]

​

[/td][td][/td][td][/td][td][/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Sheet1[/td][/tr][/table]

 

[al97233]

How about

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Fnd As Range
   If Target.Column = 3 And Target.Row = Me.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row - 2 And Target.Count = 1 And IsEmpty(Target.Value) = False Then
      Application.EnableEvents = False
   
      Me.Range("A" & Target.Row + 1).EntireRow.Insert
   
      With Me
         Set Fnd = .Range("A:A").Find("Qty", , , xlWhole, , , False, , False)
         If Not Fnd Is Nothing Then
            Fnd.Offset(1).Resize(, 4).Copy
            .Range("A" & Target.Row + 1).Resize(, 4).PasteSpecial paste:=xlPasteFormats
            .Range("D" & Target.Row + 1).FormulaR1C1 = "=rc1*rc3"
            .Range("A" & Target.Row + 1).Select
         End If
      End With
      
      Application.CutCopyMode = False
      
   End If
   Application.EnableEvents = True
   End Sub

Fluff,

this worked perfectly. thanks so much for your help!
Any idea how i can set the tab order to be B5,B6,B7,D5,D6,D7 then down to A10,B10,C10 and so on through the code you sent me? the problem I have had is i have been unable to set the tab order and protect the workbook without messing up the rest of the form.

 

[Fluff]

How about

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Fnd As Range
   If Target.Column = 3 And Target.Row = Me.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row - 2 And Target.Count = 1 And IsEmpty(Target.Value) = False Then
      Application.EnableEvents = False
      Me.Unprotect
      Me.Range("A" & Target.Row + 1).EntireRow.Insert
      
      With Me
         Set Fnd = .Range("A:A").Find("Qty", , , xlWhole, , , False, , False)
         If Not Fnd Is Nothing Then
            Fnd.Offset(1).Resize(, 4).Copy
            .Range("A" & Target.Row + 1).Resize(, 4).PasteSpecial paste:=xlPasteFormats
            .Range("D" & Target.Row + 1).FormulaR1C1 = "=rc1*rc3"
            .Range("A" & Target.Row + 1).Select
         End If
      End With
      
      Application.CutCopyMode = False
      
   End If
   Cells.Locked = True
   Range("B5:B7,D5:D7").Locked = False
   Target.Offset(1, -2).Resize(, 3).Locked = False
   Me.Protect
   Me.EnableSelection = xlUnlockedCells
   Application.EnableEvents = True
End Sub

 

[al97233]

Fluff,

This one did not work. Would it be possible for me to send you the actual workbook? Below is a image with the revisions I had to make. I apologize for not knowing more about how to code. If I did i might be able to decipher what you did and just tweak it. I'm sure something i did to the layout probably messed up you code.

Book1
	A	B	C	D
3	BAXTER & FLAMING IND., INC. 3717 NW ST HELENS ROAD PORTLAND, OR 97210 P: 503-225-0486 F: 503-227-8403		This quote is subject to withdrawal or re-quote if not accepted within 30 days. Keying is excluded. Payment terms net 30 days with approved credit. Freight is F.O.B. Our shop unless noted otherwise
4			Sales Person:	Al Dennis
5	Customer:		Date:
6	Job Name:		Phone #:
7	Attn:		Lead Time:
8	Note:	Use tab key only below this line, do not use mouse (except first cell)
9	Qty	Description	Sell	Extended
10				$0.00
11
12			Total:	$0.00
13
14
15
16
17
Sheet1

Cell Formulas
Range	Formula
D10	=A10 * C10
D12	=SUM(D10:D11)

 

[Fluff]

Please define "did not work"

 

[al97233]

it would not contain the tab series to the specified cells and when i clicked into A10 i could not enter a quantity.