How can I transfer values from a column with blanks to a column with no blanks with a prompt using VBA?

[mcarlyle]

(A) RANGE W/BLANKS	(B) RANGE W/O BLANKS
0.00020
-0.00234
-0.00231	0.00020
	-0.00234
-0.00059	-0.00231
	-0.00059
-0.04814	-0.04814
0.00000	0.00000

<tbody>
</tbody>

COUNTIF FUNCTION --->[NUMBER OF VALUES W/O BLANKS=6] VBA--- >[#BUTTON#]
​

I'm trying to transfer a column range of values with blanks into a column range with no blanks using a VBA code and a button. I have a countif function in a cell that tells me how many cells in the array are not blank. I'm using a VBA Function called NoBlanks. Currently I have to click and drag the exact number of nonblank cells into column (B) and than select the NoBlanks function, click and drag the entire range in column (A) with blanks, press ctrl+shift+enter and than it will transpose those nonblank values into column (B) without spaces, where I can use them to build a table on another page.

I'd like to attach the NoBlanks VBA Function to a button and enter the number of nonblank cells that I get from the cell containing the countif function into a prompt and have it perform this task automatically, eliminating the need to click and drag the exact number of cells into the column w/o blanks. It's important that the values be organized in ascending order without being in numerical order, that's the soul reason I have to take this approach.

Below is the VBA code for the NoBlanks function.

---

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(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

---

Any help on this matter would be greatly appreciated.

 

[Rick Rothstein]

This code will copy the values in the range A1 on down to the last filled cell in Column A over to the range starting in cell B5 and then remove the blank cells between the values...

With Range("A1", Cells(Rows.Count, "A").End(xlUp))
  .Copy .Offset(4, 1)
  .Offset(4, 1).SpecialCells(xlBlanks).Delete xlShiftUp
End With

 

[mcarlyle]

Outside of minor editing of code I'm not very good at VBA, where would I insert this line of code?