Insert Row and Copy Down From Above

[-goss]

Hi All,

I am trying to write some code to allow my users to insert a row whee
they would like and then copy the information from the row above down

Ex:

User is selected on B8 which contains "Sally Sue"
User want to add another row for Sally Sue
A row is created at Row 9 and B9 contains "Sally Sue"

My code below is giving odd results and I'm not sure why

Thanks!
goss

Sub InsertRowCurrentEmployee()

Dim wb As Workbook
Dim ws As Worksheet
Dim rngCopy As Range
Dim rngDest As Range
Dim rngStart As Range
Dim lngRows As Long
Dim R As Long


Set wb = ThisWorkbook
Set ws = wb.Worksheets("Time")

ws.Unprotect Password:="employee"

'Test to make sure at least 1 employee loaded
lngRows = ws.Range("B65536").End(xlUp).Row
Debug.Print lngRows
If lngRows >= 9 Then
R = ActiveCell.Row
Debug.Print R
Cells(R, 2).End(xlUp).Offset(1, 0).EntireRow.Insert
Debug.Print Cells(1, 2).Offset(1, 0).Address
' Set rngCopy = ws.Range("B" & R & ":J" & R)
' rngCopy.Copy Cells(R, "B").Offset(1, 0)
End If



Cleanup:

ws.Protect Password:="employee"

Set wb = Nothing
Set ws = Nothing
Set rngCopy = Nothing
Set rngDest = Nothing
Set rngStart = Nothing

ActiveSheet.Protect UserInterfaceOnly:=False
End Sub

 

[Dave Peterson]

I'm not quite sure I understand, but it looks like you're using the activesheet.

Maybe this would be enough:

Option Explicit
Sub InsertRowCurrentEmployee2()

Dim myRow As Long

myRow = ActiveCell.Row

If myRow < 9 Then
Exit Sub
End If

With ActiveSheet
.Unprotect Password:="employee"
.Rows(myRow + 1).Insert
.Cells(myRow, "B").Copy _
Destination:=.Cells(myRow + 1, "B")
.Protect Password:="employee", UserInterfaceOnly:=False
End With

End Sub

 

[Per Jessen]

Hi

Try this:

Sub InsertRowCurrentEmployee()


Dim wb As Workbook
Dim ws As Worksheet
Dim rngCopy As Range
Dim rngDest As Range
Dim rngStart As Range
Dim lngRows As Long
Dim R As Long


Set wb = ThisWorkbook
Set ws = wb.Worksheets("Time")


ws.Unprotect Password:="employee"


'Test to make sure at least 1 employee loaded
lngRows = ws.Range("B65536").End(xlUp).Row
Debug.Print lngRows
If lngRows >= 9 Then
R = ActiveCell.Row
Debug.Print R
Cells(R, 2).Offset(1, 0).EntireRow.Insert
Debug.Print Cells(1, 2).Offset(1, 0).Address
Set rngCopy = ws.Range("B" & R & ":J" & R)
rngCopy.Copy Cells(R, "B").Offset(1, 0)
End If


Cleanup:


ws.Protect Password:="employee"


Set wb = Nothing
Set ws = Nothing
Set rngCopy = Nothing
Set rngDest = Nothing
Set rngStart = Nothing


ActiveSheet.Protect UserInterfaceOnly:=False
End Sub

Regards,
Per

 

[-goss]

Hi

Try this:

Sub InsertRowCurrentEmployee()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rngCopy As Range
    Dim rngDest As Range
    Dim rngStart As Range
    Dim lngRows As Long
    Dim R As Long

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Time")

    ws.Unprotect Password:="employee"

    'Test to make sure at least 1 employee loaded
        lngRows = ws.Range("B65536").End(xlUp).Row
        Debug.Print lngRows
        If lngRows >= 9 Then
            R = ActiveCell.Row
            Debug.Print R
            Cells(R, 2).Offset(1, 0).EntireRow.Insert
            Debug.Print Cells(1, 2).Offset(1, 0).Address
            Set rngCopy = ws.Range("B" & R & ":J" & R)
            rngCopy.Copy Cells(R, "B").Offset(1, 0)
        End If

Cleanup:

        ws.Protect Password:="employee"

        Set wb = Nothing
        Set ws = Nothing
        Set rngCopy = Nothing
        Set rngDest = Nothing
        Set rngStart = Nothing

        ActiveSheet.Protect UserInterfaceOnly:=False
End Sub

Regards,
Per











- Show quoted text -

Thanks guys.
Per, works great!

Many thanks!
Regards,
goss