NONBLANKVALUES

Remove the blanks from a single column of data.
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


© 2020 Better Solutions Limited. All Rights Reserved. © 2020 Better Solutions Limited TopPrevNext