Deleteing rows without a loop meeting certain criteria - excel

I am working on writing a macro that deletes all rows that are less than .75 from a value I found using a formula. In another thread, on here, I found a loop that works, but this takes a lot of time to run... so I am trying to find a way without a loop. So far, I have the code as seen below, but i get a "run-time error 1004, method 'range of object worksheet' failed" on the line
ws.Range(Left(rowsToDelete, Len(rowsToDelete) - 1)).Select
Anybody have any ideas on a correction? All help is appreciated
Private Sub CommandButton6_Click()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim i&, lr&, rowsToDelete$, lookFor$, lookFor2$
'*!!!* set the condition for row deletion
lookFor = "#VALUE!"
lookFor2 = "0.75"
Set ws = ThisWorkbook.Sheets("Entry")
lr = ws.Range("H" & Rows.Count).End(xlUp).row
ReDim arr(0)
For i = 1 To lr
If StrComp(CStr(ws.Range("H" & i).Text), lookFor, vbTextCompare) = 0 Or _
CDbl(ws.Range("H" & i).Value) < CDbl(lookFor2) Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr) - 1) = i
End If
Next i
If UBound(arr) > 0 Then
ReDim Preserve arr(UBound(arr) - 1)
For i = LBound(arr) To UBound(arr)
rowsToDelete = rowsToDelete & arr(i) & ":" & arr(i) & ","
Next i
ws.Range(Left(rowsToDelete, Len(rowsToDelete) - 1)).Select
Selection.Delete Shift:=xlUp
lr = ws.Range("A" & Rows.Count).End(xlUp).row
ws.Range(lr & ":" & lr).Select
Else
Application.ScreenUpdating = True
MsgBox "No more rows contain: " & lookFor & "or" & lookFor2 & ", therefore exiting"
Exit Sub
End If
If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
Set ws = Nothing
End Sub

Here is one way:
Sub Macro1()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Dim r As Range
Set r = Sheet1.UsedRange
r.AutoFilter Field:=8, Criteria1:="<.75", _
Operator:=xlAnd
r.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
r.AutoFilter
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
This assumes that column H (or 8 in the code above) holds the value you want to filter for. You'll have to adjust to fit your sheet.

Related

Remove data from log on cancellation

I have some code that colours in a row of information and then stores the date and the user that coloured in said row of information on a log.
That is all well and good but I would like to somehow figure out how to reverse said process. Currently if you use the code again on the same selection the colour changes back to 'no fill' but unfortunately I'm not sure how to remove that same information that was sent to the log initially. Any ideas?
Sub CompleteLine()
Dim RCount As Integer
RCount = Selection.Columns.Count
If Selection.Interior.Color = 5296274 Then
Selection.Interior.ColorIndex = 0
Else
If RCount = 16384 And Selection.Interior.Color <> 5296274 Then
Selection.Interior.Color = 5296274
With Sheets("Log")
.Cells(1, 1).End(xlDown).Offset(1) = Format(Date, "dd/mm/yyyy")
.Cells(1, 2).End(xlDown).Offset(1) = Environ("Username")
End With
End If
End If
End Sub
Try this out. There is room for improvement, but it should work. It should at least get you started
Sub CompleteLine()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim RCount As Integer
Dim lastrow As Long
Dim checkC As Boolean
RCount = Selection.Columns.Count
With Selection
If .Interior.Color = 5296274 Then
.Interior.ColorIndex = 0
checkC = False
Else
If RCount = 16384 And .Interior.Color <> 5296274 Then .Interior.Color = 5296274
checkC = True
End If
End With
With Sheets("Log")
lastrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
If checkC = True Then
.Range("A" & lastrow & ":A" & lastrow) = Format(Date, "dd/mm/yyyy")
.Range("B" & lastrow & ":B" & lastrow) = Environ("Username")
Else
If checkC = False Then .Range("A" & lastrow & ":B" & lastrow - 1).ClearContents
End If
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

VBA delete rows that offset eachother

I am trying to eliminate line items that cancel each other out.
For example, below the two rows that add to zero would be deleted (i.e., 87.1 and -87.1).
-87.1
890
87.1
898989
The code that I am using mostly works but in cases where there are numerous lines with the same values it is deleting all of them instead of just one matching value per observation. For example, below, I would want it to cancel out two of the -87.1s and two of the 87.1s but one would be leftover because there is no number directly offsetting it.
-87.1
890
87.1
898989
87.1
-87.1
-87.1
Sub x()
Dim n As Long, rData As Range
Application.ScreenUpdating = False
n = Range("C" & Rows.Count).End(xlUp).Row
Range("AV2:AV" & n).Formula = "=IF(I2=0,0,COUNTIFS($C$2:$C$" & n & ",C2,$I$2:$I$" & n & ",-I2))"
With ActiveSheet
.AutoFilterMode = False
.Rows(1).AutoFilter field:=48, Criteria1:=">0"
With .AutoFilter.Range
On Error Resume Next
Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rData Is Nothing Then
rData.EntireRow.Delete shift:=xlUp
End If
End With
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
I think you need something like this:
Sub DeleteOppositeNumbers()
Dim Fnd As Range, r As Long
'By: Abdallah Ali El-Yaddak
Application.ScreenUpdating = False
'Loop through the column bottom to top.
For r = Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
If Cells(r, 3).Value > 0 Then 'If the value is positive
'Sreach for it's opposite
Set Fnd = Columns(3).Find(-Cells(r, 3).Value, LookAt:=xlWhole)
'If found, delete both.
If Not Fnd Is Nothing Then Rows(r).Delete: Fnd.EntireRow.Delete
End If
Next
'Just to restore normal behaviour of sreach
Set Fnd = Columns(3).Find(Cells(3, 2).Value, LookAt:=xlPart)
Application.ScreenUpdating = True
End Sub
Perhaps Something Simpler:
Sub x()
Dim ar() As Variant
Dim i As Integer
Dim j As Integer
Dim n As Integer
n = Range("C" & Rows.Count).End(xlUp).Row
Range("AV2:AV" & n).Formula = "=IF(I2=0,0,COUNTIFS($C$2:$C$" & n & ",C2,$I$2:$I$" & n & ",-I2))"
ar = ActiveSheet.Range("AV2:AV" & last).Value
For i = LBound(ar) To UBound(ar)
For j = LBound(ar) To UBound(ar)
If i <> j Then
If ar(i, 1) = ar(j, 1) Then
ar(i, 1) = ""
ar(j, 1) = ""
End If
End If
Next
Next
For i = LBound(ar) To UBound(ar)
ActiveSheet.Range("AV" & i + 1).Value = ar(i, 1)
Next
ActiveSheet.Range("AV2:AV" & last).SpecialCells(xlCellTypeBlanks).Delete xlUp
End Sub
I have tried and tested this one.
You could try:
Option Explicit
Sub test()
Dim arr As Variant
Dim LastRow As Long, i As Long, j As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = Range("A1:A" & LastRow)
For i = UBound(arr) To LBound(arr) Step -1
For j = UBound(arr) - 1 To LBound(arr) Step -1
If arr(i, 1) + arr(j, 1) = 0 Then
.Rows(i).EntireRow.Delete
.Rows(j).EntireRow.Delete
Exit For
End If
Next j
Next i
End With
End Sub

Delete blank rows other than first column

I have written a macro to delete the row if it is a blank row or if in column B the cell contains the string XYZ. However, this macro can take a couple minutes to run if there is 200+ rows of data. Can anyone provide anything more efficient in VBA format?
Sub DeleteBlanks()
Dim lr As Long, r As Long
For r = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
Range("B" & r).Replace "*XYZ*", "", xlWhole
If Range("B" & r).Value = "" Then
Range("B" & r & ":Q" & r).Delete (xlShiftUp)
End If
Next r
Application.ScreenUpdating = False
End Sub
I would add the ScreenUpdating line to the top, and also turn calculation to manual:
Sub DeleteBlanks()
Dim lr As Long, r As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For r = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
Range("B" & r).Replace "*XYZ*", "", xlWhole
If Range("B" & r).Value = "" Then
Range("B" & r & ":Q" & r).Delete (xlShiftUp)
End If
Next r
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
As you have it, the entire macro runs, then the screenUpdating is turned off. You can speed it up by putting that up front, then turning it back on when the macro is finished.
In addition to what #BruceWayne said, I will shorten the code
Range("B" & r).Replace "*XYZ*", "", xlWhole
If Range("B" & r).Value = "" Then
With
If Range("B" & r).Value = "" Or InStr(1, Range("B" & r).Value, "XYZ") > 0 then
That will lower the actions that the code needs to make.
First of all, the screen updating should be disabled before the proccess, and re-enabled after that, so the screen will not flash, and load of resources will not be high.
Other than that, text replacement is completely unneeded in your case.
By reading your current code, I assume you consider a blank row if it's empty on column B.
Try this:
Sub DeleteBlanks()
Application.ScreenUpdating = False
Dim lr As Long, r As Long
For r = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
If Range("B" & r).Value = "" Or Range("B" & r).Value Like "*XYZ*" Then
Range("B" & r & ":Q" & r).Delete (xlShiftUp)
End If
Next r
Application.ScreenUpdating = True
End Sub
This solution should be virtually instantaneous:
Public Sub Colin_H()
Dim v, rCrit As Range, rData As Range
With [a1]
Set rData = .Resize(.Item(.Parent.Rows.Count).End(xlUp).Row, .Item(, .Parent.Columns.Count).End(xlToLeft).Column)
End With
Set rCrit = rData.Resize(2, 2).Offset(, rData.Columns.Count + 1)
rCrit.Resize(1) = rData(1, 2): rCrit(2, 1) = "*": rCrit(2, 2) = "<>*xyz*"
rData.AdvancedFilter xlFilterCopy, rCrit, rCrit.Resize(1, 1).Offset(, 2)
With rCrit.Resize(1, 1).Offset(, 2).Resize(rData.Rows.Count, rData.Columns.Count)
v = .Value2
rData = v
.ClearContents
rCrit.ClearContents
End With
End Sub
Notice that there is no looping, no row shifting, and no iterated range construction.
This uses the advanced filter of the range object to filter your records in one quick blast to a range adjacent to your source data. The result is then copied over the source without using the clipboard. There is no quicker or more efficient way to achieve your objective.

faster deletion of rows

the code below allows me to delete rows if a cells contains certain values. now for some reason it takes me a lot of time(30 mins and counting).
' to delete data not meeting criteria
Worksheets("Dashboard").Activate
n1 = Range("n1")
n2 = Range("n2")
Worksheets("Temp Calc").Activate
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For z = lastrow To 2 Step -1
If Cells(z, 6).Value = "CNF" Or Cells(z, 4).Value <= n1 Or Cells(z, 3).Value >= n2 Then
Rows(z).Delete
End If
Next z
a google search and some talk with forum member sam provided me with two options
to use filter.(i do want to use this).
using arrays to store the entire worksheet and then copy data that only matches my criteria.He was kind enough to help me come up with the following code.But i am not familiar with working on data in an array.
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Column.Count).End(xlRight).Row
arr1 = Range("A1:Z" & lastrow)
ReDim arr2(1 To UBound(arr1, 1), 1 To UBound(arr1, 2))
j = j + 1
For i = 1 To UBound(arr1, 1)
If arr1(i, 6) <> "CNF" And arr1(i, 4) > n1 And arr1(i, 3) < n2 Then
For k = 1 To lastCol
arr2(j, k) = arr1(i, k)
Next k
j = j + 1
End If
Next i
Range(the original bounds) = arr2
my question is is there a faster way of deleting rows in an array other than the ones mentioned above? Or is array or filter the best options i've got.I am open to suggestions.
Update my new code looks like this. it does not filter the date rangeeven if they are hardcoded can anybody tell me what i am doing wrong ?
Option Explicit
Sub awesome()
Dim Master As Workbook
Dim fd As FileDialog
Dim filechosen As Integer
Dim i As Integer
Dim lastrow, x As Long
Dim z As Long
Application.ScreenUpdating = False
Dim sngStartTime As Single
Dim sngTotalTime As Single
Dim ws As Worksheet
Dim FltrRng As Range
Dim lRow As Long
Dim N1 As Date, N2 As Date
sngStartTime = Timer
Sheets("Dashboard").Select
N1 = Range("n1").Value
N2 = Range("n2").Value
Sheets("Temp Calc").Select
'Clear existing sheet data except headers
'Sheets("Temp Calc").Select
'Rows(1).Offset(1, 0).Resize(Rows.Count - 1).ClearContents
'The folder containing the files to be recap'd
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "G:\Work\" '<----- Change this to where the files are stored.
fd.InitialView = msoFileDialogViewList
'allow multiple file selection
fd.AllowMultiSelect = True
fd.Filters.Add "Excel Files", "*.xls*"
filechosen = fd.Show
'Create a workbook for the recap report
Set Master = ThisWorkbook
If filechosen = -1 Then
'open each of the files chosen
For i = 1 To fd.SelectedItems.Count
Workbooks.Open fd.SelectedItems(i)
With ActiveWorkbook.Worksheets(1)
Range("O2", Range("O" & Cells(Rows.Count, "O").End(xlUp).Row)).Copy Master.Worksheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Range("p2", Range("P" & Cells(Rows.Count, "P").End(xlUp).Row)).Copy Master.Worksheets(2).Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Range("Q2", Range("Q" & Cells(Rows.Count, "Q").End(xlUp).Row)).Copy Master.Worksheets(2).Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
Range("R2", Range("R" & Cells(Rows.Count, "R").End(xlUp).Row)).Copy Master.Worksheets(2).Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
Range("A2", Range("A" & Cells(Rows.Count, "A").End(xlUp).Row)).Copy Master.Worksheets(2).Range("E" & Rows.Count).End(xlUp).Offset(1, 0)
Range("AC2", Range("AC" & Cells(Rows.Count, "AC").End(xlUp).Row)).Copy Master.Worksheets(2).Range("F" & Rows.Count).End(xlUp).Offset(1, 0)
End With
' Sheets(1).Range("D4", Sheets(1).Range("D" & Sheets(1).Cells(Rows.Count, "D").End(xlUp).Row)).Copy Sheets(2).Range("B" & Sheets(2).Rows.Count).End(xlUp).Offset(1, 0)
ActiveWorkbook.Close (False)
Next i
End If
Set ws = ThisWorkbook.Worksheets("Temp Calc")
'~~> Start Date and End Date
N1 = #5/1/2012#: N2 = #7/1/2012#
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Get the last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Identify your data range
Set FltrRng = .Range("A1:F" & lRow)
'~~> Filter the data as per your criteria
With FltrRng
'~~> First filter on blanks
.AutoFilter Field:=6, Criteria1:="="
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'~~> Delete the filtered blank rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
ws.ShowAllData
'~~> Next filter on Start Date
.AutoFilter Field:=3, Criteria1:="<" & N1, Operator:=xlAnd
'~~> Finally filter on End Date
.AutoFilter Field:=4, Criteria1:=">" & N2, Operator:=xlAnd
'~~> Filter on col 6 for CNF
'.AutoFilter Field:=6, Criteria1:="CNF"
'~~> Delete the filtered rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'~~> Remove any filters
.AutoFilterMode = False
End With
sngTotalTime = Timer - sngStartTime
MsgBox "Time taken: " & (sngTotalTime \ 60) & " minutes, " & (sngTotalTime Mod 60) & " seconds"
Application.Goto (ActiveWorkbook.Sheets("Dashboard").Range("A4"))
Sheets("Dashboard").Select
Application.ScreenUpdating = True
End Sub
this works for me ..... thank you everyone.... it is achieved using an advanced filter
Dim x, rng As Range
x = Array("BENIN-00001", "BENIN-00002", "BENTB-0001", "BENTB-0002", "BENTB-0003", "BENTB-0004", _
"BENTB-0005", "BENTB-0006", "BENTB-0007", "BENTB-0008", "BENTH-00001", "CRPTB-00002", "GDSGL-00001", _
"GDSIN-00001", "GDSIN-00002", "GDSIN-00003", "LSIED-00001", "LSIES-00001", "PRSGS-00001", "PRSGS-00002", _
"PRSGS-00003", "PRSGS-00006", "PRSGS-00007", "PRSGS-00008", "PRSPS-00001", "PRSPS-00002", "PRSTB-0001", _
"PRSTB-0002", "PRSTB-0003", "PRSTB-0004", "PRSTB-0005", "PRSTB-0006", "PRSTB-0007", "SNMIN-00001", "SNMIN-00002", _
"TRGIN-00001", "TRGIN-00002", "TRGTH-00001", "BENEU-00002", "BENEU-00003", "GDSEU-00002", "GDSEU-00003", _
"GDSEU-00004", "PRSGS-00005", "PRSGS-00061", "PRSPS-00004", "PRSPS-00005", "TRGEU-00002", "TRGGB-00001", _
"BENMX-00001", "BENUS-00001", "BENUS-00002", "GDSCA-00001", "GDSGL-00002", "GDSMX-00001", "GDSUS-00001", _
"GDSUS-00002", "LSIPP-00001", "PRSGS-00004", "PRSPS-00003", "TRGMX-00001", "TRGUS-00001")
With Sheets("Temp Calc").Cells(1).CurrentRegion
On Error Resume Next
.Columns(6).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
Set rng = .Offset(, .Columns.Count + 1).Cells(1)
.Cells(1, 5).Copy rng
rng.Offset(1).Resize(UBound(x) + 1).Value = Application.Transpose(x)
.AdvancedFilter 1, rng.CurrentRegion
.Offset(1).EntireRow.Delete
On Error Resume Next
.Parent.ShowAllData
On Error GoTo 0
rng.EntireColumn.Clear
End With

Cut and Paste Rows, Why So Slow, Trying To Speed Up Performance

I have a small estimating worksheet I have made where you type in line items with a description, quantity and price. As it happens you often want to organize your data. In this case I would like to have the ability to move a range of cells up or down the list. (No data is being deleted, just shifting the range up or down) I am simply trying to cut and paste the data up or down one row at a time. I have an Up Arrow and Down Arrow for users to click on to activate the macro, one for up and one for down.
I have successfully written the macro code to make this happen, however it uses the select command and is very slow. I have used the same code before on another project and it was much faster, almost instant, the only difference that I can think of is that I was selecting the the ENTIRE row. In this particular instance I am only wanting to move the data in Columns B thru N. Columns O thru Y have fixed inputs and cannot be moved.
Below is the working code to move the range up.
Sub MoveUp()
Application.ScreenUpdating = False
ActiveSheet.Unprotect 'Unprotects The Sheet
If Not Intersect(ActiveCell, Range("B12:F98")) Is Nothing Then 'Makes sure you are within the correct range, cannot move top row up
Range("B" & ActiveCell.Row & ":" & "N" & ActiveCell.Row).Select 'Selects only area you want to move
Selection.Rows(Selection.Rows.Count + 1).Insert Shift:=xlDown
Selection.Rows(1).Offset(-1).Cut Selection.Rows(Selection.Rows.Count + 1)
Selection.Rows(1).Offset(-1).Delete Shift:=xlUp
Selection.Offset(-1).Select 'This keeps the cell you moved selected so you can keep moving it without having to reselect
Else
MsgBox "You Can't Move That Row Up"
End If
Call ResetRanges 'Resets the named ranges
Call ProtectWorkSheet 'Protects The Sheet
Application.ScreenUpdating = True
End Sub
I wrote an alternative macro without using select, trying to use defined ranges and use offsets to make the shift happen, but it was still just as slow as the above code. Am I missing something?
Sub MoveUpRangeMethod()
Application.ScreenUpdating = False
activerow = ActiveCell.Row
endon = activerow - 1
Set rng = Range("B" & activerow & ":" & "N" & activerow)
Set rng2 = Range("B" & activerow - 1 & ":" & "N" & activerow - 1)
rng3 = ("F" & endon)
rng.Cut
rng2.Insert Shift:=xlDown
Range(rng3).Activate
Application.ScreenUpdating = True
End Sub
Update:
I wrote the macro out another way and it still performs slowly. I think that there is something else behind the scenes causing the slowdown. It could quite possibly be from some bad code I have elsewhere. Below is the new code I tried, again, it works fast in a new sheet, but struggles in the workbook where I need it.
Sub ShiftCellsDown()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayAlerts = False
ws.Range("B" & ActiveCell.Row - 1 & ":" & "N" & ActiveCell.Row - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ws.Range("B" & ActiveCell.Row - 1 & ":" & "N" & ActiveCell.Row - 1).Value = ws.Range("B" & ActiveCell.Row + 1 & ":" & "N" & ActiveCell.Row + 1).Value
ws.Range("B" & ActiveCell.Row + 1 & ":" & "N" & ActiveCell.Row + 1).Delete Shift:=xlUp
ws.Range(("F" & ActiveCell.Row - 1)).Activate
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
How about the following, I've just simplified your code a little and added a couple of lines for better performance:
Sub MoveUpRangeMethod()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayAlerts = False
ws.Range("B" & ActiveCell.Row & ":" & "N" & ActiveCell.Row).Cut
ws.Range("B" & ActiveCell.Row - 1 & ":" & "N" & ActiveCell.Row - 1).Insert Shift:=xlDown
ws.Range("F" & ActiveCell.Row - 1).Activate
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
UPDATE:
The following update might help, instead of Cut & Insert Ranges, it assigns the values into Arrays and then passes them values into the desired cells, thus hopefully speeding up the process:
Sub MoveUpRangeMethod()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Dim Arr() As Variant, Arr2() As Variant ' declare two unallocated arrays.
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayAlerts = False
If ActiveCell.Row > 2 Then
Arr = ws.Range("B" & ActiveCell.Row & ":" & "N" & ActiveCell.Row).Value ' Arr is now an allocated array
Arr2 = ws.Range("B" & ActiveCell.Row - 1 & ":" & "N" & ActiveCell.Row - 1).Value ' Arrw is now an allocated array
ws.Range("B" & ActiveCell.Row).Resize(UBound(Arr2, 1), UBound(Arr2, 2)).Value = Arr2
ws.Range("B" & ActiveCell.Row - 1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
ws.Range("F" & ActiveCell.Row - 1).Activate
End If
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Resources