VBE313
Well-known Member
- Joined
- Mar 22, 2019
- Messages
- 686
- Office Version
- 365
- Platform
- 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: