NONBLANKVALUES

Remove the blanks from a single column of data.
For instructions on how to add a function to a workbook refer to the page under Inserting Functions

enter as an array formula returns an array to multiple cells

'rgeValues - 
'lArrayFormulaSize - 
'bIncludeRowNo - 

Public Function NONBLANKVALUES(ByVal rgeValues As Range, _ 
                             ByVal lArrayFormulaSize As Long, _ 
                    Optional ByVal bIncludeRowNo As Boolean = False) As Variant 
Dim lrowno As Long 
Dim larrayno As Long 
Dim avalues As Variant 
Dim iupper As Integer 

   If bIncludeRowNo = False Then iupper = 1 
   If bIncludeRowNo = True Then iupper = 2 
   ReDim avalues(1 To iupper, 1 To rgeValues.Rows.Count) 
   For lrowno = 1 To rgeValues.Rows.Count 
      If Len(rgeValues.Parent.Cells(rgeValues.Row + lrowno - 1, rgeValues.Column).Value) > 0 Then 
         avalues(1, 1 + larrayno) = rgeValues.Parent.Cells(rgeValues.Row + lrowno - 1, rgeValues.Column).Value 
         If bIncludeRowNo = True Then 
            avalues(2, 1 + larrayno) = rgeValues.Row + lrowno - 1 
         End If 
         larrayno = larrayno + 1 
      End If 
   Next lrowno 
   
   ReDim Preserve avalues(1 To iupper, 1 To lArrayFormulaSize) 
   For lrowno = (larrayno + 1) To lArrayFormulaSize 
      avalues(1, lrowno) = "" 
      If bIncludeRowNo = True Then 
         avalues(2, lrowno) = "" 
      End If 
   Next lrowno 
   
   avalues = Application.WorksheetFunction.Transpose(avalues) 
   NONBLANKVALUES = avalues 

End Function 

Function NoBlanks(DataRange As Range) As Variant() ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
' NoBlanks
' This function returns an array that consists of the non-blank values ' in DataRange. The function must be array-entered into the complete range ' of worksheet cells that are to receive the result. For example, if ' you want the results in B1:B10, select that range, type
'       =NOBLANKS(A1:A10)
' in B1 and press CTRL+SHIFT+ENTER rather than just enter.
' This will cause the function to fill B1:B10 with the N non-blank ' entries in A1:A10, and place vbNullStrings in N+1 to 10.
' The input DataRange must have exactly 1 row or 1 column. You ' can't enter a two-dimensional array. The formula must be ' entered into a single column or singe row. You cannot ' enter the formula in a two dimensional array. If the formula ' is entered into a two-dimensional range, or if DataRange is a ' two dimensional range, the function will return #REF errors.
' The size of the array is the greater of the number of cells ' into which it was entered and the number of cells in the input ' DataRange.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim N As Long 
Dim N2 As Long 
Dim Rng As Range 
Dim MaxCells As Long 
Dim Result() As Variant 
Dim R As Long 
Dim C As Long 

If (DataRange.Rows.Count > 1) And _ 
    (DataRange.Columns.Count > 1) Then 
    '''''''''''''''''''''''''''''''''''''''''''''''''
    ' If DataRange is a two-dimensional array, fill
    ' it with #REF errors. We work with only
    ' single dimensional ranges.
    '''''''''''''''''''''''''''''''''''''''''''''''''
    ReDim Result(1 To DataRange.Rows.Count, 1 To DataRange.Columns.Count) 
    For R = 1 To UBound(Result, 1) 
        For C = 1 To UBound(Result, 2) 
            Result(R, C) = CVErr(xlErrRef) 
        Next C 
    Next R 
    NoBlanks = Result 
    Exit Function 
End If 

If (Application.Caller.Rows.Count > 1) And _ 
    (Application.Caller.Columns.Count > 1) Then 
    '''''''''''''''''''''''''''''''''''''''''''''''''
    ' If Application.Caller is a two-dimensional array, fill
    ' it with #REF errors. We work with only
    ' single dimensional ranges.
    '''''''''''''''''''''''''''''''''''''''''''''''''
    ReDim Result(1 To Application.Caller.Rows.Count, 1 To Application.Caller.Columns.Count) 
    For R = 1 To UBound(Result, 1) 
        For C = 1 To UBound(Result, 2) 
            Result(R, C) = CVErr(xlErrRef) 
        Next C 
    Next R 
    NoBlanks = Result 
    Exit Function 
End If 
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get the greater of Application.Caller.Cells.Count ' and DataRange.Cells.Count. This is the size ' of the array we'll return. Sizing it to the ' maximum value prevents #N/A error from appearing ' in cells past the end of the array, because ' the array will always fill out the cells ' into which it was entered.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
MaxCells = Application.WorksheetFunction.Max( _ 
    Application.Caller.Cells.Count, DataRange.Cells.Count) 

''''''''''''''''''''''''''''''''''''''''''''
' Resize the array to the proper size.
''''''''''''''''''''''''''''''''''''''''''''
ReDim Result(1 To MaxCells, 1 To 1) 
''''''''''''''''''''''''''''''''''''''''''''
' Loop through DataRange and place non-blank ' cells at the front of the array.
''''''''''''''''''''''''''''''''''''''''''''
For Each Rng In DataRange.Cells 
    If Rng.Value <> vbNullString Then 
        N = N + 1 
        Result(N, 1) = Rng.Value 
    End If 
Next Rng 
''''''''''''''''''''''''''''''''''''''''''''
' Fill the remaining array elements with ' vbNullStrings so they don't appear ' as 0 on the worksheet.
''''''''''''''''''''''''''''''''''''''''''''
For N2 = N + 1 To MaxCells 
    Result(N2, 1) = vbNullString 
Next N2 

'''''''''''''''''''''''''''''''''''''''''''
' If the formula was entered into a single ' row across several columns, Transpose the ' result array.
'''''''''''''''''''''''''''''''''''''''''''
If Application.Caller.Rows.Count = 1 Then 
    NoBlanks = Application.Transpose(Result) Else 
    NoBlanks = Result 
End If 

End Function