Hi rs1aj
Try this Code in the attached...CTRL + x will fire the Code.
Option Explicit
Sub DeleteBlankRows1()
Dim LR As Long
Dim LC As Long
Dim Rng As Range
Dim i As Long
Dim Wks As Worksheet
Set Wks = Sheets("Sheet1")
With Wks
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set Rng = .Range(.Cells(1, 1), .Cells(LR, LC))
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We work backwards because we are deleting rows.
For i = Rng.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Rng.Rows(i)) = 0 Then
Rng.Rows(i).EntireRow.Delete
End If
Next i
End With
FillColBlanks_Offset
With Wks
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set Rng = .Range(.Cells(1, 3), .Cells(LR, 3))
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We work backwards because we are deleting rows.
For i = Rng.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Rng.Rows(i)) = 0 Then
Rng.Rows(i).EntireRow.Delete
End If
Next i
With .Range("A2:A" & LR)
.HorizontalAlignment = xlLeft
End With
.Columns("F:F").Delete
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub FillColBlanks_Offset()
'by Rick Rothstein 2009-10-24
'fill blank cells in column with value above
'http://www.contextures.com/xlDataEntry02.html
' Select Column First
Dim Area As Range, LastRow As Long
On Error Resume Next
LastRow = Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas).Row
Columns(1).Select
For Each Area In ActiveCell.EntireColumn(1).Resize(LastRow). _
SpecialCells(xlCellTypeBlanks).Areas
Area.Value = Area(1).Offset(-1).Value
Next
Columns(2).Select
For Each Area In ActiveCell.EntireColumn(1).Resize(LastRow). _
SpecialCells(xlCellTypeBlanks).Areas
Area.Value = Area(1).Offset(-1).Value
Next Area
Columns(4).Select
For Each Area In ActiveCell.EntireColumn(1).Resize(LastRow). _
SpecialCells(xlCellTypeBlanks).Areas
Area.Value = Area(1).Offset(-1).Value
Next
End Sub
Bookmarks