PDA

View Full Version : Solved: VBA code for removing blank cells in a list



paulxl
01-27-2012, 11:52 AM
I have a spreadsheet that will return both values and " " values in a column. I need to extract the values from this column and place them in a report. The data in the column will change on a regular basis and hence the number of lines in the report will also vary. I have been trying to adapt Chip Pearson's code listed below without success. This would be fine if the non value cells were blank but the fact that they contain a " " renders the macro unusable. Any ideas to adapt this would be greatly appreciated.
Function NoBlanks(RR As Range) As Variant
Dim Arr() As Variant
Dim R As Range
Dim N As Long
Dim L As Long
If RR.Rows.Count > 1 And RR.Columns.Count > 1 Then
NoBlanks = CVErr(xlErrRef)
Exit Function
End If

If Application.Caller.Cells.Count > RR.Cells.Count Then
N = Application.Caller.Cells.Count
Else
N = RR.Cells.Count
End If

ReDim Arr(1 To N)
N = 0
For Each R In RR.Cells
If Len(Trim(R.Value)) > 0 Then
N = N + 1
Arr(N) = R.Value
End If
Next R
For L = N + 1 To UBound(Arr)
Arr(L) = vbNullString
Next L
ReDim Preserve Arr(1 To L)
If Application.Caller.Rows.Count > 1 Then
NoBlanks = Application.Transpose(Arr)
Else
NoBlanks = Arr
End If
End Function

jolivanes
01-27-2012, 12:29 PM
paulxl
Single line code like that is hard to comprehend but could you insert a TRIM function somewhere?

Or something like



If c.Value = " " Then EntireRow.Delete

paulxl
01-27-2012, 12:43 PM
Sorry about the code. Have corrected it now. I did try replacing the line If Len(R.Value) > 0 Then

with If Len(Trim(R.Value)) > 0 Then

but this just repeated the first value in the list. Not certain where I should insert your code

Kenneth Hobs
01-27-2012, 01:15 PM
Replacing that line of code worked for me.

' Chip Pearson, http://www.cpearson.com/excel/NoBlanks.aspx
Function NoBlanks(RR As Range) As Variant
Dim Arr() As Variant
Dim R As Range
Dim N As Long
Dim L As Long
If RR.Rows.Count > 1 And RR.Columns.Count > 1 Then
NoBlanks = CVErr(xlErrRef)
Exit Function
End If

If Application.Caller.Cells.Count > RR.Cells.Count Then
N = Application.Caller.Cells.Count
Else
N = RR.Cells.Count
End If

ReDim Arr(1 To N)
N = 0
For Each R In RR.Cells
' Trim added cells with just space characters to be considered empty.
' http://www.vbaexpress.com/forum/showthread.php?t=40685
If Len(Trim(R.Value)) > 0 Then
N = N + 1
Arr(N) = R.Value
End If
Next R
For L = N + 1 To UBound(Arr)
Arr(L) = vbNullString
Next L
ReDim Preserve Arr(1 To L)
If Application.Caller.Rows.Count > 1 Then
NoBlanks = Application.Transpose(Arr)
Else
NoBlanks = Arr
End If
End Function

jolivanes
01-27-2012, 01:28 PM
I am not much of a coder Paul but you could try



Set Rng = Range(Rows(1), _
Rows(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row()))
RwCnt = 0
For Rw = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(Rw).EntireRow) = 0 Then
Rng.Rows(Rw).EntireRow.Delete
RwCnt = RwCnt + 1
End If
Next Rw


If you put this just below the "Dim L As Long" statement, it might work.
I am sure that someone else will come up with a much better solution (I hope so anyway).
In the meantime you could try it on a copy of your workbook.

paulxl
01-27-2012, 01:30 PM
Not working for me. I just get the first value repeated. Tried using the formula NoBlanks with cell references and range reference, as an array formula and without the array brackets but all with the same result

Kenneth Hobs
01-27-2012, 01:33 PM
I can't see over your shoulder so either use Chip's file or post your problem file. In Chip's file add the space character to a "blank" cell and test. Of course you need to replace that one line of code in his routine.

jolivanes
01-27-2012, 01:42 PM
You have Kenneth Hobs on your side so I'll just follow the thread so I can learn from Kenneth also.

paulxl
01-27-2012, 01:53 PM
OK. Here is a sample of what I'm trying to do. Can't use the real data as it is sensitive.

The blue box is a range called Number and the red box contains the formula

paulxl
01-27-2012, 01:55 PM
Thanks for trying jolivanes, eh!

Kenneth Hobs
01-27-2012, 02:16 PM
I did not see a red box in our example. In this one based on your last file, I showed both routines. I just changed the one that we modified to be NoBlanks2(). I only set one cell with a space character so that you could compare the two routines.

jolivanes
01-27-2012, 02:18 PM
I found this in my storage drawer.
It works on your example eh!!



Sub DelBlankRws()
Application.ScreenUpdating = False
start = Timer
Cells.AutoFilter
With ActiveSheet.Range("$C$3", Range("C" & Rows.Count).End(xlUp))
.AutoFilter Field:=1, Criteria1:=" "
.EntireRow.Delete
End With
Cells.AutoFilter
Application.ScreenUpdating = True
MsgBox "Macro took " & (Timer - start) & " seconds to run."
End Sub


Good luck
John

paulxl
01-27-2012, 02:38 PM
Sorry to be such a pain but I now realise that I should have told you that the data was a formula result and not randomly entered data. This still leaves me with my original problem as you can see from the new boxes I've included on you example. I don't know what colour the supposed red box on my first attachment really was, and being somewhat colour blind I'm not even going to hazard a guess on the colours of the new boxes

paulxl
01-27-2012, 02:46 PM
Good try jolivanes but there is info in the columns either side of the " "'s

Kenneth Hobs
01-27-2012, 02:59 PM
I call that light green for the border. If you hover over a color in the color picker dialog, for some colors, you get a description for what that is worth.

I still can not duplicate your problem. When I select N3:N12, press F2, press Ctrl+Shift+Enter, 1-7 is filled as expected.

Maybe you should explain how you do your thing. Keep in mind that I am slow...

paulxl
01-27-2012, 03:09 PM
OK. Please kick me! I've been entering the array formula wrong! I've been arraying the first cell and then copying it down. Don't know when I got into that bad habit, haven't worked with array formulas for a while.

Sorry to have taken up so much of your time but I do appreciate your quick responses and I can at least go to bed with something accomplished tonight.

Yours shamefacedly

Paul

jolivanes
01-27-2012, 03:29 PM
Just for the heck of it.
If you do have problems with colors, this will give you the right border color of the selected cell



Sub ShowColour()
Dim RGBColour As String, R As Integer, G As Integer, B As Integer
RGBColour = Right("000000" & Hex(ActiveCell.Borders(xlEdgeRight).Color), 6)
R = WorksheetFunction.Hex2Dec(Right(RGBColour, 2))
G = WorksheetFunction.Hex2Dec(Mid(RGBColour, 3, 2))
B = WorksheetFunction.Hex2Dec(Left(RGBColour, 2))
MsgBox "RGB" & vbTab & R & ", " & G & ", " & B & vbCrLf & "Index" & vbTab & ActiveCell.Borders(xlEdgeRight).ColorIndex
End Sub

paulxl
01-27-2012, 05:44 PM
jolivanes. I have no problem at all with colours but it does occur to me that everyone else doesn't see what I see!

Seriously, though, I often put a border round a cell and then need to use the same colour later for another cell for continuity. I usually find I can't remember what colour I used and end up having to recolour both borders just to make sure I have the same colour, so your code is going to come in useful. Thanks