Easier way to write this?

VBE313

VBE313

Well-known Member
Joined
Mar 22, 2019
Messages
686
Office Version
  1. 365
Platform
  1. Windows
I created an excel template that forces the user to enter data in every other column. What this code is meant to do is "delete" the active row of data and move up the data below it. I have it searching every 40 rows down to see if there is a value in there, if there is not a value then it knows to start copying from there. Is there a easier/ more efficient way of writing this code? Thanks

Code: 
Sub testerdelete()        
    Application.ScreenUpdating = False
        Application.EnableEvents = False
        ActiveSheet.unprotect 
    Set rngstart = ActiveCell
        l = ActiveCell.Row
        strCells = "B" & l
    If ActiveCell.Column = 6 And ActiveCell.Row >= 5 And ActiveSheet.Name = "BOM" Then
        Msg = "Are you sure you want to delete this row?"
        Ans = MsgBox(Msg, vbYesNo)
    Select Case Ans
    Case vbYes
        Range(strCells).Offset(2, 0).Select
    If ActiveCell.Offset(22, 0).Value = "" Then
        numrows = 21
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(60, 0).Value = "" Then
        numrows = 59
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(100, 0).Value = "" Then
        numrows = 99
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(120, 0).Value = "" Then
        numrows = 119
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(160, 0).Value = "" Then
        numrows = 159
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(200, 0).Value = "" Then
        numrows = 199
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(220, 0).Value = "" Then
        numrows = 219
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(260, 0).Value = "" Then
        numrows = 259
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(300, 0).Value = "" Then
        numrows = 299
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(320, 0).Value = "" Then
        numrows = 319
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(360, 0).Value = "" Then
        numrows = 359
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(400, 0).Value = "" Then
        numrows = 399
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(420, 0).Value = "" Then
        numrows = 419
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(460, 0).Value = "" Then
        numrows = 459
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(500, 0).Value = "" Then
        numrows = 499
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(520, 0).Value = "" Then
        numrows = 519
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
    If ActiveCell.Offset(560, 0).Value = "" Then
        numrows = 559
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
   Else
   If ActiveCell.Offset(600, 0).Value = "" Then
        numrows = 599
        numcolumns = 27
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.Copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range(strCells).Select
    Else
        MsgBox "Contact admin"
    End If 'For ActiveCell.Offset(20, 0).Value
    End If 'For ActiveCell.Offset(60, 0).Value
    End If 'For ActiveCell.Offset(100, 0).Value
    End If 'For ActiveCell.Offset(120, 0).Value
    End If 'For ActiveCell.Offset(160, 0).Value
    End If 'For ActiveCell.Offset(200, 0).Value
    End If 'For ActiveCell.Offset(220, 0).Value
    End If 'For ActiveCell.Offset(260, 0).Value
    End If 'For ActiveCell.Offset(300, 0).Value
    End If 'For ActiveCell.Offset(320, 0).Value
    End If 'For ActiveCell.Offset(360, 0).Value
    End If 'For ActiveCell.Offset(400, 0).Value
    End If 'For ActiveCell.Offset(420, 0).Value
    End If 'For ActiveCell.Offset(460, 0).Value
    End If 'For ActiveCell.Offset(500, 0).Value
    End If 'For ActiveCell.Offset(520, 0).Value
    End If 'For ActiveCell.Offset(560, 0).Value
    End If 'For ActiveCell.Offset(600, 0).Value
    Case vbNo
    GoTo Quit:
    End Select
Quit:
    Else
        MsgBox "Please select a cell in the description column in the BOM"
    End If
        rngstart.Select
        Application.Run "indenting" 
        Sheets("BOM").Select
        rngstart.Select
        ActiveSheet.Protect 
        Application.ScreenUpdating = True
        Application.EnableEvents = True
End Sub
 
Last edited by a moderator:

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
Figured it out I believe

Code: 
Sub testerdelete()         
      Application.ScreenUpdating = False
        Application.EnableEvents = False
        ActiveSheet.unprotect Password:="RM28"
    Set rngstart = ActiveCell
        l = ActiveCell.Row
        strCells = "B" & l
    If ActiveCell.Column = 6 And ActiveCell.Row >= 5 And ActiveSheet.Name = "BOM" Then
        Msg = "Are you sure you want to delete this row?"
        Ans = MsgBox(Msg, vbYesNo)
    Select Case Ans
    Case vbYes
        Range("F" & Rows.Count).End(xlUp).Select
        r = ActiveCell.Row
        toprange = "B" & r
        numrows = (r - l) + 1
        numcolumns = 27
        Range(strCells).Select
    Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Select
        Selection.copy
        Selection.Offset(-2, 0).Select
        Selection.PasteSpecial
        Range("F" & Rows.Count).End(xlUp).Select
        Application.Run "NoIndentLevel"
        Range(strCells).Select
    Case vbNo
    GoTo Quit:
    End Select
Quit:
 Else
        MsgBox "Please select a cell in the description column in the BOM"
        ActiveSheet.Protect Password:="RM28"
    End If
        rngstart.Select
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        ActiveSheet.unprotect Password:="RM28"
        Sheets("BOM").Select
        rngstart.Select
        ActiveSheet.Protect Password:="RM28"
        Application.ScreenUpdating = True
        Application.EnableEvents = True
End Sub
 
Last edited by a moderator:
Upvote 0
I did not understand what the pattern is.
But try the following.


Code: 
Sub testerdelete()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect
    Set rngstart = ActiveCell
    l = ActiveCell.Row
    strCells = "B" & l
    If ActiveCell.Column = 6 And ActiveCell.Row >= 5 And ActiveSheet.Name = "BOM" Then
        ans = MsgBox("Are you sure you want to delete this row?", vbYesNo)
        If ans = vbNo Then Exit Sub
    Else
        MsgBox "Please select a cell in the description column in the BOM"
        Exit Sub
    End If
    
    Range(strCells).Offset(2, 0).Select
    If ActiveCell.Offset(22, 0).Value = "" Then
        numrows = 21
        numcolumns = 27
        Set newrange = ActiveCell.Resize(numrows, numcolumns)
        newrange.Copy
        newrange.Offset(-2, 0).PasteSpecial
    Else
        i = 60
        For j = 1 To 17
            If ActiveCell.Offset(i, 0).Value = "" Then
                numrows = i - 1
                numcolumns = 27
                Set newrange = ActiveCell.Resize(numrows, numcolumns)
                newrange.Copy
                newrange.Offset(-2, 0).PasteSpecial
                Exit For
            End If
            i = i + 40
        Next
    End If


    Application.Run "indenting"
    Sheets("BOM").Select
    rngstart.Select
    ActiveSheet.Protect
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
 
Upvote 0
Just a note regarding your code. You can usually shorten and speed up your code by removing a lot of your Select statements. It is usually not necessary to select ranges to work with them.

For example, this:
Code: 
[COLOR=#333333]newrange.Select[/COLOR]
[COLOR=#333333]Selection.copy[/COLOR]
[COLOR=#333333]Selection.Offset(-2, 0).Select[/COLOR]
[COLOR=#333333]Selection.PasteSpecial[/COLOR]
can be simplified to this:
Code: 
newrange.Copy
newrange.Offset(-2, 0).PasteSpecial
or possibly even:
Code: 
newrange.Copy newrange.Offset(-2, 0)
(depending on what you are hoping to accomplish with "PasteSpecial" as opposed to just "Paste").


EDIT: Dante's code uses this version, so you can see it in action. I started drafting this reply a while ago before he replied, but got pulled away, and when I posted, I see that he had replied.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA If statement to continue
2
Replies
17
Views
653
dinunan
D
N
  • Question Question
VBA Questions - Copying dynamic data from one tab to another and deleting filtered rows
Replies
1
Views
478
DanteAmor
DanteAmor
J
  • Question Question
Why isn't my loop looping?
Replies
4
Views
509
Joe4
Joe4
Rhodie72
  • Question Question
How to write a data to a text file (VBA)
2
Replies
17
Views
1K
Rhodie72
Rhodie72
C
  • Solved
With 'Set StrVal=ActiveCell.Address' and ‘Dim StrVal As String’ I get 'Object required' error With ‘Dim StrVal As Range’, a ‘Type Mismatch’ error
Replies
7
Views
487
MARK858
MARK858

Forum statistics

Threads
1,224,818
Messages
6,181,151
Members
453,021
Latest member
Justyna P

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