Attached screenshot will explain it better.... I am trying to write macro which will do the following:
When cell A is empty, copy value of cell A from the cell above
and delete that row above that cell which was empty… or
In the table shown delete Row 2 but copy cell A2 into A3 before Row 3 deletion
So far I got this but after that I am confused what to do next...anybody can help?
Sub RowAboveDelete()
Dim ws As Worksheet: Set ws = Sheets("Sheet2")
Dim lr As Long
lr = ws.Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long
For i = lr To 1 Step -1
If IsEmpty(ws.Cells(i, 1)) Then
ws.Rows(i).Offset(-1).Delete
End If
Next i
End Sub
Attached screenshot will explain it better.... I am trying to write macro which will do the following:
When cell A is empty, copy value of cell A from the cell above
and delete that row above that cell which was empty… or
In the table shown delete Row 2 but copy cell A2 into A3 before Row 3 deletion
So far I got this but after that I am confused what to do next...anybody can help?
Sub RowAboveDelete()
Dim ws As Worksheet: Set ws = Sheets("Sheet2")
Dim lr As Long
lr = ws.Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long
For i = lr To 1 Step -1
If IsEmpty(ws.Cells(i, 1)) Then
ws.Rows(i).Offset(-1).Delete
End If
Next i
End Sub
5 Answers
Reset to default 2Remove Old Data, Keep First Old Column
Main
Sub RemoveOldData()
' Define constants.
Const PROC_TITLE As String = "Remove Old Data"
Const SHEET_NAME As String = "Sheet2"
Const TOP_LEFT_CELL As String = "A2"
' Reference the objects.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets(SHEET_NAME)
Dim rg As Range: Set rg = RefCurrentRegion(ws.Range(TOP_LEFT_CELL))
Dim crg As Range: Set crg = rg.Columns(1)
Dim drg As Range
With rg
Set drg = rg.Resize(, .Columns.Count - 1).Offset(, 1)
End With
' Copy the values from the criteria column to an array.
Dim cData() As Variant: cData = GetRange(crg)
' Retrieve the last (range) row index, the first to be processed.
Dim cRow As Long: cRow = rg.Rows.Count
' Declare additional variables.
Dim RowsCount As Long, TotalRowsCount As Long
Dim IsCellBlank As Boolean, IsBlankCellFound As Boolean
' Loop from bottom to top.
Application.ScreenUpdating = False
Do While cRow > 0
IsCellBlank = (Len(CStr(cData(cRow, 1))) = 0)
If IsBlankCellFound Then
RowsCount = RowsCount + 1 ' number of rows to delete
If Not IsCellBlank Then
' Delete rows.
Union(crg.Rows(cRow + 1).Resize(RowsCount), _
drg.Rows(cRow).Resize(RowsCount)).Delete xlShiftUp
' Count and reset.
TotalRowsCount = TotalRowsCount + RowsCount
RowsCount = 0
IsBlankCellFound = False
End If
Else
' Flag.
If IsCellBlank Then IsBlankCellFound = True
End If
cRow = cRow - 1
Loop
Application.ScreenUpdating = True
' Inform.
MsgBox TotalRowsCount & " row" & IIf(TotalRowsCount = 1, "", "s") _
& " of old data removed.", _
IIf(TotalRowsCount = 0, vbExclamation, vbInformation), PROC_TITLE
End Sub
Help
Function RefCurrentRegion(topLeftCell As Range) As Range
If topLeftCell Is Nothing Then Exit Function
With topLeftCell.Cells(1).CurrentRegion
Set RefCurrentRegion = topLeftCell.Resize(.Row + .Rows.Count _
- topLeftCell.Row, .Column + .Columns.Count - topLeftCell.Column)
End With
End Function
Function GetRange(ByVal rg As Range) As Variant
If rg Is Nothing Then Exit Function
With rg.Areas(1)
If rg.Cells.CountLarge = 1 Then
Dim Data() As Variant: ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = .Value
GetRange = Data
Else
GetRange = .Value
End If
End With
End Function
It is simpler to delete the the next row then the previous row. Allow .Offset(-1).Delete would work for this use case, it still should be avoided.
My code is using Union to delete the empty cell and the cells from the row above that need deleting in a single operation. This not only simplifies the code but is faster.
Sub RowAboveDelete()
Application.ScreenUpdating = False
Dim Target As Range
Set Target = Sheets("Sheet2").Range("A1").CurrentRegion
Dim r As Long
For r = Target.Rows.Count - 1 To 1 Step -1
If Len(Target(r + 1, 1)) = 0 Then
Union(Target(r + 1, 1), Target.Rows(r).Offset(, 1)).Delete xlShiftUp
End If
Next
Application.ScreenUpdating = True
End Sub
If there is no formatting, using arrays will be exponentially faster then deleting cells. But that is the subject for another post.
You are almost there, just need to copy the cell from above.
Sub RowAboveDelete()
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
' Set the worksheet you are working on
Set ws = ThisWorkbook.Sheets("Sheet2")
' Find the last row in column B
lr = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
' Optimize performance - optional
' Application.ScreenUpdating = False
' Application.Calculation = xlCalculationManual
On Error Resume Next ' Prevent unexpected errors from halting the macro
For i = lr To 2 Step -1 ' Loop from the last row upwards to row 2
If IsEmpty(ws.Cells(i, 1)) Then ' Check if cell in column A is empty
If Not IsEmpty(ws.Cells(i - 1, 1)) Then ' Ensure the row above is valid
ws.Cells(i, 1).Value = ws.Cells(i - 1, 1).Value ' Copy value from the row above
End If
ws.Rows(i - 1).Delete ' Delete the row above
End If
Next i
On Error GoTo 0 ' Reset error handling
' Restore application settings
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Process completed successfully!", vbInformation
End Sub
Loop through all cells in column A and populate the rows above. Loading data from a sheet into an array for processing is more efficient when working with large datasets.
Option Explicit
Sub Demo()
Dim rngData As Range, lastRow As Long
Dim i As Long, j As Long, rngDel As Range, arrData
With Sheets("Sheet1") ' modify as needed
lastRow = .Cells.Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Set rngData = .Range("A1:D" & lastRow)
End With
arrData = rngData.Value
For i = LBound(arrData) To UBound(arrData)
If Len(arrData(i, 1)) = 0 And i > 1 Then
For j = LBound(arrData, 2) + 1 To UBound(arrData, 2)
arrData(i - 1, j) = arrData(i, j)
Next
End If
Next i
rngData.Value = arrData
On Error Resume Next
Set rngDel = rngData.Columns(1).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngDel Is Nothing Then
rngDel.EntireRow.Delete
End If
End Sub
If you'd like to retain the formatting (e.g., fill color, font) of rows with a blank cell in the first column, please try the following:
Sub Demo2()
Dim rngData As Range
Dim i As Long, j As Long, rngDel As Range, arrData
Dim lastRow As Long, ColCnt As Long
With Sheets("Sheet1") ' modify as needed
lastRow = .Cells.Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False).Row
ColCnt = .UsedRange.Columns.Count
Set rngData = .Range("A1").Resize(lastRow, ColCnt)
End With
arrData = rngData.Value
For i = LBound(arrData) To UBound(arrData)
If Len(arrData(i, 1)) = 0 And i > 1 Then
Cells(i, 2).Resize(1, ColCnt - 1).Copy Cells(i - 1, 2)
End If
Next i
On Error Resume Next
Set rngDel = rngData.Columns(1).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngDel Is Nothing Then
rngDel.EntireRow.Delete
End If
End Sub
I wanted to keep the majority of your code and make it as simple as possible.
Option Explicit
Sub RowAboveDelete()
'I made it here the ActiveSheet simply because I don't know which sheet you would like to use.
Dim ws As Worksheet: Set ws = ActiveSheet
Dim lr As Long
lr = ws.Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long
For i = lr To 1 Step -1
If IsEmpty(ws.Cells(i, 1)) Then
'Copy the Range into the above row
'We are just copying the values here and not the formatting hence the " = " otherwise you could use ".Copy"
ws.Range("B" & i - 1, "D" & i - 1).Value = ws.Range("B" & i, "D" & i).Value
'Delete the Row that has been copied
ws.Rows(i).Delete
End If
Next i
'check the last cell again
lr = ws.Cells(Rows.Count, 2).End(xlUp).Row
'make the bottom border thick again
With ws.Range("A" & lr, "D" & lr).Borders(xlEdgeBottom)
.Weight = xlThick
End With
End Sub