Use specific cell instead of ActiveCell

[sparky2205]

Hi folks,
I'm trying to create a macro that will allow the user to input newrows in a protected worksheet based on a starting point and a number ofrows.
The newly entered rows will be copies of the row above where the new rows willbe entered. That row contains formulas which must copy with the rows.
I can get this working using ActiveCell but I don’t want the user to have to selectthe row in the worksheet before running the macro.
So what I want is to allow the user toenter the starting position and the number of rows and based on this informationperform the task.

This is where I’m at but I’m having aproblem assigning the starting position to a variable.

Sub InsertMultipleRows()
Dim s As Variant
Dim n As Variant
Dim r As Range
'Get the starting position
s= Application.InputBox("Enter the starting position", , , , , , , 1 +2)
If s = False Then
Exit Sub
ElseIf s = "" Then
Exit Sub
End If
r= "A" & s
'Get the number of rows to input
n= Application.InputBox("Enter the number of rows to input", , , , , ,, 1 + 2)
If n = False Then
Exit Sub
ElseIf n = "" Then
Exit Sub
End If
'Unprotect the sheet
ActiveSheet.Unprotect Password:=""
'Copy the cell
r.EntireRow.Copy
'Fill down the required numbe of times
Range(r.Offset(1, 0), r.Offset(n, 0)).EntireRow.Insert Shift:=xlDown
Application.CutCopyMode = False
End Sub

I think the problem is with r = "A" & s
I’m getting the “Object variable or Withblock variable not set” error.

Any help would be greatly appreciated.

 

[sparky2205]

My fault first time round. I hadn't run the code so of course it didn't work.
Using ?r.Address in the Immediate Window I stepped through the code and checked the address of r at each point.
It was all as expected. However I still got the error "Application-defined or object-defined error" when the starting point is a blank cell.
When I clear the error the lines have been created with the starting position highlighted as if I was copying it.
Another test:
I ran the macro with the starting position being a populated cell.
All ran fine.
Then I populated cell A1 of one of the newly created rows with some text and reran the macro using that as the starting point.
All ran fine.
Then I ran the macro again with the starting position being a blank cell on a newly created row.
I got the error.
So the problem is definately with the starting position being a blank cell.

 

[Fluff]

I cannot replicate that particular error message, so not sure what to suggest.

 

[sparky2205]

It must be something in my setup.
Is there any way I can send you my file?

 

[sparky2205]

Another piece of information related to this.
If the row is populated in ANY cell the code will work. It can have the starting position cell blank as long as the entire row is not blank.

 

[Fluff]

If the row is completely blank I would expect an error of 1004 "No cells were found", rather than "Application-defined or object-defined error".

 

[sparky2205]

Good morning Fluff,
I am definitely getting the 1004 error "Application-defined or object-defined error".
The code is definitely crashing at the line...

"Rows(s).Resize(n).SpecialCells(xlConstants).ClearContents"

...when the line that has been copied is blank.
Would it be possible to add a check to the code that only runs that line of code when the copied line is not blank?

 

[sparky2205]

Hello again,
I got a workable solution so I thought I'd post it here for closure.
Instead of only running that line of code when the copied line is not blank I made sure the copied line would never be blank.
Here's the finished code...

Sub InsertMultipleRows()
    Dim s As Variant
    Dim n As Variant
    Dim r As Range
    
    On Error GoTo Errhandler:
    
    Application.ScreenUpdating = False
    
    ' Get the starting position
    s = Application.InputBox("Enter the starting position", , , , , , , 1 + 2)
    ' If the user clicks on Cancel
    If s = False Then
        Exit Sub
        ' If the user clicks on OK but doesn't enter a number
        ElseIf s = "" Then
        Exit Sub
        End If
    ' Populate variable r with the starting range
    Set r = Range("A" & s)
    ' Get the number of rows to input
    n = Application.InputBox("Enter the number of rows to input", , , , , , , 1 + 2)
    ' If the user clicks on Cancel
    If n = False Then
        Exit Sub
        ' If the user clicks on OK but doesn't enter a number
        ElseIf n = "" Then
        Exit Sub
    End If
    ' Copy the row
    r.EntireRow.Copy
    ' Fill down the required numbe of times
    Range(r.Offset(1, 0), r.Offset(n, 0)).EntireRow.Insert Shift:=xlDown
    ' Populate the first cell of each newly created row with the word Text
    Range(r, r.Offset(n - 1, 0)) = ("Text")
    ' Clear the contents of the copied rows except for formulas
    Rows(s).Resize(n).SpecialCells(xlConstants).ClearContents
    ' Don't copy to clipboard
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
    
    Exit Sub
    
Errhandler:
    Exit Sub
    
End Sub

This is the line I added which populates the first cell in each newly copied row with the word Text.

Range(r, r.Offset(n - 1, 0)) = ("Text")

I still don't know why I was getting the error but at least now I have a working solution.

Thanks very much for your persistence with this Fluff, especially as you couldn't reproduce the problem.
I wouldn't have gotten to this point without your help.

 

[sparky2205]

Hi folks,
I'm adding this request to this existing post as I see it as an extension of the same thing rather than something new.
I need an update to the code to be able to insert 4 rows from a particular starting point which will be specified
by the user. The new rows will need to copy the formulas and formatting of the 4 rows either directly above or
directly below, doesn't matter which.
I've made a few attempts and I've managed to copy and paste the 4 rows but my paste overwrites existing

cells rather then inserts new rows.
I think I need to use the filldown method but I can't get my head around how.
This is where I'm at:

s = Application.InputBox("Enter the starting position", , , , , , , 1 + 2)
    ' If the user clicks on Cancel
    If s = False Then
        Exit Sub
        ' If the user clicks on OK but doesn't enter a number
        ElseIf s = "" Then
        Exit Sub
        End If
    ' Copy and Paste the cells
    ActiveSheet.Range("A" & s & ":AX" & (s + 3)).Copy Destination:=ActiveSheet.Range("A" & (s + 4))

This works but over writes existing cells rather than inserts the copied cells between existing cells.
As usual any help is much appreciated.

 

[sparky2205]

I got this to work so I decided to post it here in case it may help someone else.

Sub InsertVendor()

    Dim s As Variant
    Dim r As Variant
     
    ' Don't update the screen until the macro has finished processing
    Application.ScreenUpdating = False
    
    ' Get the starting position
    s = Application.InputBox("Enter a new vendor after vendor...?", , , , , , , 1 + 2)
    ' If the user clicks on Cancel
    If s = False Then
        Exit Sub
        ' If the user clicks on OK but doesn't enter a vendor name
        ElseIf s = "" Then
        Exit Sub
        End If
    ' Find the row number of the vendor
    r = Application.Match(s, Sheets("Revised").Range("B:B"), 0)
    ' If the vendor is not found
    If IsError(r) Then
        MsgBox ("Vendor '" & s & "' not found")
        Exit Sub
    End If
    ' Select the cells to copy
    Rows(r & ":" & (r + "3")).Select
    ' Copy the cells
    Selection.Copy
    ' Select where to insert the cells
    Rows(r + "4" & ":" & r + "4").Select
    ' Insert the cells
    Selection.Insert shift:=xlDown
    ' Select the Vendor Name in the newly created cells
    Range("B" & (r + "4") & ":" & "B" & (r + "7")).Select
    ' Delete the Vendor Name from the newly created cells
    Selection.ClearContents
    ' Select Vendor Number and Ratings from the newly created cells
    Range("C" & (r + "4") & ":" & "G" & (r + "4")).Select
    ' Clear the Vendor Number and Ratings from the newly created cells
    Selection.ClearContents
    
    ' Turn this back on
    Application.ScreenUpdating = True

End Sub