Deleting Blank Rows..Consolidating Data

[detailstx]

I have a spreadsheet that includes data pasted from another source, but problem is that I have many blank rows between each block of data. Is there a macro that would delete the blank rows and move the data up?
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Goal is to consolidate the data from column A to R and Row 8 to the very last row.
<o></o>
Appreciate any help.<o></o>

 

[VoG]

Try

Sub btest()
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
Range("A8:A" & LR).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub

 

[detailstx]

Macro works perfectly if there are gaps in raw data. Problem with mine is that the data is pasted from a sheet with cells that are formatted. It seems as thought there is residual formatting in the blank cells (rows) and the above macro reads these cells as containing something, other than nothing.

Does that make sense?

My previous macro to eliminate blanks is:

Sub NoBlks()
Dim Lastrow As Long, i As Long, j As Integer
Application.ScreenUpdating = False
With ActiveSheet
For j = 1 To 59
Lastrow = .Cells(Rows.Count, j).End(xlUp).Row
For i = Lastrow To 2 Step -1
'If (IsEmpty(.Cells(i, j).Value)) Then .Cells(i, j).Delete shift:=xlShiftUp
If (.Cells(i, j).Value = "") Then .Cells(i, j).Delete shift:=xlShiftUp
If (.Cells(i, j).Value = " ") Then .Cells(i, j).Delete shift:=xlShiftUp
Next i
Next j
End With
Application.ScreenUpdating = True
End Sub

But I want it to eliminate blanks from row 8 to the bottom.

Can you help?

 

[VoG]

That would be

For i = Lastrow To 8 Step -1

But it might be faster to select column A then run the TrimAll macro http://dmcritchie.mvps.org/excel/join.htm then run the code that I posted earlier.

 

[detailstx]

I figured it out...Thanks for the help.

 

[detailstx]

One more thing.

I was given an awesome macro that serves my purpose, with the exception of shifting all the data to row 5. Can you see if you could incorporate the NoBlks() with Import()...goal is to have NoBlks() become the very last task in Import()? I am a laughably pathetic novice.


Option Explicit
Sub Import()
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now

Set wsMaster = ThisWorkbook.Sheets("Data") 'sheet report is built into
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.Cells.Clear
NR = 1
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'Path and filename (edit this section to suit)
MsgBox "Please select a folder with files to consolidate"
Do
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
fPath = .SelectedItems(1) & "\"
Exit Do
Else
If MsgBox("No folder chosen, do you wish to abort?", _
vbYesNo) = vbYes Then Exit Sub
End If
End With
Loop
fPathDone = fPath & "Archived\" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*.xls*") 'listing of desired files, edit filter as desired
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'This is the section to customize, replace with your own action code as needed
With wbData.Sheets("JobData")
LR = .Range("A" & .Rows.Count).End(xlUp).Row 'Find last row
If NR = 1 Then 'copy the data AND titles
.Range("A1:A" & LR).EntireRow.Copy
Else 'copy the data only
.Range("A2:A" & LR).EntireRow.Copy
End If
End With
.Range("A" & NR).PasteSpecial xlPasteValues 'paste values into master

wbData.Close False 'close file
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
fName = Dir 'ready next filename
End If
Loop
End With
ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
__________________________________

Sub NoBlks()
Dim Lastrow As Long, i As Long, j As Integer
Application.ScreenUpdating = False
With ActiveSheet
For j = 1 To 16
Lastrow = .Cells(Rows.Count, j).End(xlUp).Row
For i = Lastrow To 5 Step -1
'If (IsEmpty(.Cells(i, j).Value)) Then .Cells(i, j).Delete shift:=xlShiftUp
If (.Cells(i, j).Value = "") Then .Cells(i, j).Delete shift:=xlShiftUp
If (.Cells(i, j).Value = " ") Then .Cells(i, j).Delete shift:=xlShiftUp
Next i
Next j
End With
Application.ScreenUpdating = True
End Sub

Apprectiate the help.

 

[VoG]

This should work

ErrorExit: 'Cleanup
Call NoBlks
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub

 

[detailstx]

JACKPOT!

Thanks a lot and take care.