Below is the code I have. I am looking to loop through the blank cells in the range to return the values. I want to then add these values to a list and print them.

Sub NDJList()

Dim List() As Variant
Dim Alert, Today As Date
Dim Days, Due As Integer
Dim rng, Cell As Range
Dim x As Long

On Error Resume Next
    ActiveSheet.ShowAllData
'Determine the data to store
Set rng = Range(Range("C4"), Range("C" & Rows.Count).End(xlUp))
With rng
    .AutoFilter 7, ""
    Set blanks = .Offset(1, 0).SpecialCells(xlCellTypeVisible)

'Resize Array prior to loading data
ReDim List(blanks.Rows.Count)

'Loop through each cell in range and store value in Array
    For Each Cell In blanks
        Alert = Cell.Offset(0, 4)
        Today = Format(Now(), "dd-mmm-yy")
        Days = Alert - Today
        'Due = Days * (-1)
        List(x) = Array(Cell.Offset(0, 3).Value)
        x = x   1
    Next Cell
 'Print values to Immediate Window
        For x = LBound(List) To UBound(List)
            Debug.Print List(x)
        Next x
End With
End Sub

All it does is return a blank value in the Immediate window

CodePudding user response：

Please, try the next adapted code. If filters the used range of the active sheet, filters on the blank cells of "G:G" column, set the array dimensions using Subtotal and returns in array from column "F:F". There are Date calculations not used in the code, I do not understand where to be used...:

Sub NDJList()
 Dim List() As Variant, Alert As Date, Today As Date
 Dim Days As Integer, Due As Integer
 Dim rng As Range, Cell As Range, x As Long, rowsCount As Long

 If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

 'Determine the data to store:???
 Set rng = Range(Range("C4"), Range("C" & rows.count).End(xlUp))

 ActiveSheet.AutoFilter 7, "" 'filter the activesheet used range
 rowsCount = Application.WorksheetFunction.Subtotal(3, rng) - 1 'numbers of rows in discontinuous range, except headers one
 With rng
        Set blanks = .Offset(1).Resize(rng.rows.count - 1).SpecialCells(xlCellTypeVisible)
    
       'Resize Array prior to loading data
       ReDim List(rowsCount - 1) 'zero based array...
    
       'Loop through each cell in range and store value in Array
        For Each Cell In blanks
            'Alert = Cell.Offset(0, 4)   '??? not used...
            'Today = Format(Now(), "dd-mmm-yy") '??? not used...
            'Days = Alert - Today       '??? not used...
            List(x) = Cell.Offset(, 3).Value: x = x   1
      Next Cell
 End With
 
  'Print values to Immediate Window
  For x = LBound(List) To UBound(List)
        Debug.Print List(x)
  Next x

End Sub

Commented the unused lines. Anyhow, Offset(,4) should return from the filtered column, meaning only blank cells, making the respective lines raising errors...

Not tested, but it should work.

CodePudding user response：

Get Unique Strings From Filtered Column

Usage

Sub GetNDJListTEST()
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Debug.Print GetNDJList(ws)
End Sub

Result for the data in the screenshot:

S
T
J
U
Z
Q
I
O
P
D

The Function

Function GetNDJList(ByVal ws As Worksheet) As String
    
    Const FIRST_ROW As Long = 4
    Const DATA_COLUMN As Long = 6
    Const FILTER_COLUMN As Long = 7
    Const FILTER_STRING As String = ""

    If ws.FilterMode Then ws.ShowAllData
    
    Dim srg As Range, sdrg As Range, rOffset As Long, rCount As Long
    
    With ws.UsedRange
        rOffset = FIRST_ROW - .Row
        rCount = .Rows.Count - rOffset
        Set srg = .Resize(rCount).Offset(rOffset) ' has headers
        Set sdrg = srg.Resize(rCount - 1).Offset(1) ' no headers
    End With
           
    srg.AutoFilter FILTER_COLUMN, FILTER_STRING
    
    Dim drg As Range
    On Error Resume Next
        Set drg = sdrg.Columns(DATA_COLUMN).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ws.AutoFilterMode = False
        
    If drg Is Nothing Then Exit Function ' no filtered values
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim dCell As Range, dString As String
    
    For Each dCell In drg.Cells
        dString = CStr(dCell.Value)
        If Len(dString) > 0 Then
            If Not dict.Exists(dString) Then dict(dString) = Empty ' first occ.
        End If
    Next dCell
    
    If dict.Count = 0 Then Exit Function ' just blanks
    
    GetNDJList = Join(dict.Keys, vbLf)

End Function