Assign unique values into an Array

Question

Please can you advise how I may be able to assign the unique values held in column E and the count of the unique values in column E into an array.

    Sub TestLines()
    Windows("InvoiceSenseCheck.xlsx").Activate
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Integer
    Set wb = ActiveWorkbook
    Set ws = Sheets("VARs")
With ws
        lastRow = .Range("E" & .Rows.Count).End(xlUp).Row - 1 'count number of rows in column
        MsgBox lastRow
        ' Declare an array to hold Accounts
        Dim TenAcc(1 To 20) As String
        ' Read Accounts from cells E2:E into array
        Dim i As Integer
        For i = 1 To lastRow                        'I could just have entered 20 here
            TenAcc(i) = .Range("E1").Offset(i)
        Next i
        ' List Accounts from the array
        Debug.Print "Tenens Acc"                    'Test the output
        For i = LBound(TenAcc) To UBound(TenAcc)
            Debug.Print TenAcc(i)                   'Test the output
        Next i
End With
 End Sub

I appreciate that “ Dim TenAcc (1 To 20) As String “ is an Array but I am not sure how to place a the value from lastRow where 20 is currently located. I have tried various methods to convert

I am further aware that the lastRow statement is counting the total and not the total unique values, this is just for me to test.

I have done a lot of reading and testing, put simply, my knowledge or understanding is just not good enough to solve the problem.

I’d appreciate any advise

Thanks

Pros

I have been asked to provide more information therefore here goes;

Many thanks for all your suggestions, I particularly like EvR’s solution as it provided the total of unique values in the range, however it does not add these values to an Array.

To be honest I am cheating by taking the values from column E of the VAR sheet, I’m only doing this so that I can use these values to argue against another data set later in the query. Whilst this works the code is very inefficient as I may only want to export data for 10 values in a list of 500, hence wanting to find the unique values and run the code the number of times I have a unique value. I have added the complete code for reference purposes.

Therefore rather than assigning the unique values from Column E on the ‘VAR’ sheet, they should come from Column A on the ‘Sheet1’ sheet. This sheet can contain thousands of rows for let’s say 10 unique clients and therefore I need to create 10 separate files, i.e. run the loop 10 times. Currently I am running it as many times as we have potential clients, whilst I have set this to 20 for testing it is in fact hundreds, which makes the code inefficient to run, it works, but that’s not the point.

    Sub TestLines()

Dim wb As Workbook
Dim ws As Worksheet

    Set wb = ActiveWorkbook
    Set ws = Sheets("VARs")

        With ws
            ' Declare an array to hold Accounts
            Dim TenAcc(1 To 21) As String
            ' Read Accounts from cells E2:E20 into array
            Dim i As Integer
            For i = 1 To 21
                TenAcc(i) = .Range("E1").Offset(i)
            Next i
            For i = LBound(TenAcc) To UBound(TenAcc)

      Worksheets("Sheet1").Activate
           Set rRange = Worksheets("Sheet1").Range("A2", Range("A" & Rows.Count).End(xlUp))
      For Each rCell In rRange
        tCell = rCell.Value
        tAcc = TenAcc(i)
     'MsgBox "rCell= " & tCell & "    " & "Ten Acc= " & tAcc
            If rCell.Value = TenAcc(i) Then
                RateAcc = rCell(1, 1)
                DelCol = rCell(1, 2)
                LedgerAcc = rCell(1, 3)
                Cost = rCell(1, 4)      'Don't Export
                JobDate = rCell(1, 5)
                items = rCell(1, 6)
                Weight = rCell(1, 7)
                Reference = rCell(1, 8)
                Address = rCell(1, 9)
                Town = rCell(1, 10)
                Pcode = rCell(1, 11)
                SvcCode = rCell(1, 12)
                Charge = rCell(1, 13)
      dd = Left(InvDate, 2)
      mm = Mid(InvDate, 4, 2)
      yy = Right(InvDate, 2)
    '    MsgBox yy & mm & dd 'Test
    FilePath = "\\Sunbury-tpn\tpn\Parcels\Attachments\"
    FilePathName = FilePath & yy & mm & dd & "-" & LedgerAcc & "-" & RateAcc & "-" & "TRAN.csv"
                If Not fso.FolderExists(FilePath) Then fso.CreateFolder (FilePath)  'create folder if it does not exist
    Set inputFile = fso.OpenTextFile(FilePathName, 8, True)
    inputFile.WriteLine (Chr(34) & RateAcc & Chr(34) & "," & Chr(34) & DelCol & Chr(34) & "," & Chr(34) & LedgerAcc & Chr(34) & _
    "," & Chr(34) & JobDate & Chr(34) & "," & Chr(34) & items & Chr(34) & "," & Chr(34) & Weight & Chr(34) & "," & Chr(34) & _
    Reference & Chr(34) & "," & Chr(34) & Address & Chr(34) & "," & Chr(34) & Town & Chr(34) & "," & Chr(34) & Pcode & Chr(34) & _
    "," & Chr(34) & SvcCode & Chr(34) & "," & Chr(34) & Charge & Chr(34))

    inputFile.Close
            End If 'rCell
        Next rCell
    '       MsgBox "FilePathName = " & FilePathName  'Test
    If fso.FileExists(FilePathName) Then
        Workbooks.Open Filename:=FilePathName
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
          Cells(lastrow + 2, 12).Formula = "=sum(L1:L" & lastrow & ")"
    tVar = Cells(lastrow + 2, 12)
    '   MsgBox RateAcc & " " & tVar  'Test
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=FilePathName, _
            FileFormat:=xlCSV, Local:=True, CreateBackup:=False
        ActiveWorkbook.Close savechanges:=True
    Application.DisplayAlerts = True
        FilePathNameTmp = FilePath & yy & mm & dd & "_Inv_Totals.csv"
    Set inputFile = fso.OpenTextFile(FilePathNameTmp, 8, True)
    inputFile.WriteLine (Chr(34) & RateAcc & Chr(34) & "," & Chr(34) & tVar & Chr(34))
    inputFile.Close
        FilePathName = ""  'Empty the path as not required

    End If
            Next i
    End With
        '------------------------------------
        FilePath = "C:\users\" & UserName & "\Desktop\"
    ActiveWorkbook.Close savechanges:=False

    If fso.FileExists(FilePath & "InvoiceSenseCheck.xlsx") Then
    fso.DeleteFile FilePath & "InvoiceSenseCheck.xlsx", True
    Else
    MsgBox "Nothing to Delete"
    End If

    MsgBox "The newly created attachment files" & Chr(13) & "are located here:-" & Chr(13) & Chr(13) & "\\Sunbury-tpn\tpn\Parcels\Attachments"

    Application.ScreenUpdating = True

    End If 'File does not exist

    End Sub

I do hope this all makes sense.

Many thanks

Answer 1

I beleive the easiest way is to use function ReDim this way:

ReDim TenACC (1 To 20)
ReDim Preserve TenACC (1 To lastRow)

As I know, it is very important yo declare the array using ReDim and not Dim to make it work

Answer 2

a solution without looping:

Sub tst()
Dim a As String, TenAcc() As String
    a = Worksheets("VARs").Range("e2", Worksheets("VARs").Range("e2").End(xlDown)).Address
    TenAcc = Filter(Application.Transpose(Application.Evaluate("=IF(FREQUENCY(MATCH(" & a & "," & a & ",0),MATCH(" & a & "," & a & ",0))>0," & a & ")")), False, False, 0)
    Debug.Print "Total unique values : " & UBound(TenAcc) + 1
End Sub

Answer 3

Range, Array, Array (, Range)

Highlights

• Calculates the Source Range and pastes it into the Source Array.
• Calculates the number of Unique Values while copying them to the beginning of the Source Array replacing the original values.
• Writes the Unique Values to Target Array.
• Additionally pastes the Target Array into Target Range specified by its First Cell if enabled (cBlnPaste = True).

The Code

Option Explicit

Sub TestLines()

'***************************************
  ' Additional Functionality
  Const cBlnPaste As Boolean = False    ' Enable Paste To Range Functionality
  Const cStrFirstCell As String = "F1"  ' First Cell (of Target Column)
'***************************************

  Const cIntHeaders As Integer = 0      ' Number of Header Rows
  ' Workbook Name
  Const cStrWb As String = "InvoiceSenseCheck.xlsx"
  Const cVntWs As String = "VARs"       ' Worksheet Name or Index e.g. "VR" or 1
  Const cVntColumn As Variant = "E"     ' Source Column e.g. "E" or 5

  Dim vntSource As Variant              ' Source Array
  Dim vntTarget As Variant              ' Target Array

  Dim i As Long, j As Long, k As Long   ' Various Row Counters
  Dim blnFound As Boolean               ' Unique Values Checker

  ' Paste Source Range into Source Array (vntSource).
  With Workbooks(cStrWb).Worksheets(cVntWs)
    vntSource = .Range(.Cells(cIntHeaders + 1, cVntColumn), _
        .Cells(Rows.Count, cVntColumn).End(xlUp))
  End With

  ' Debug
  For i = 1 To UBound(vntSource): Debug.Print vntSource(i, 1): Next

  ' Count the number of Unique Values (k) while copying them to the beginning
  ' of Source Array replacing the original values.
  For i = 1 To UBound(vntSource)
    If vntSource(i, 1) <> "" Then
      For j = 1 To i - 1
        If vntSource(i, 1) = vntSource(j, 1) Then
          blnFound = True
          Exit For
        End If
      Next
      If blnFound Then
        blnFound = False
       Else
        k = k + 1
        vntSource(k, 1) = vntSource(i, 1)
      End If
    End If
  Next
  ' Remarks: Unique Values are now at the beginning of Source Array (vntSource).
  '          Since this is a 2D array, Redim Preserve cannot be used.

  ' Debug
  Debug.Print "The Number of Unique Values is " & k & "."

  ' Write Unique Values to Target Array (vntTarget).
  ReDim vntTarget(1 To k, 1 To 1)
  For i = 1 To k
    vntTarget(i, 1) = vntSource(i, 1)
  Next
  Erase vntSource

  ' Debug
  For i = 1 To UBound(vntTarget): Debug.Print vntTarget(i, 1): Next

'***************************************
  ' Additional Functionality
  If cBlnPaste Then
    With Workbooks(cStrWb).Worksheets(cVntWs)
      ' Clear the contents of Target Column starting from First Cell.
      .Range(cStrFirstCell) _
          .Resize(Rows.Count - .Range(cStrFirstCell).Row + 1).ClearContents
      ' Paste Target Array into Target Range
      .Range(cStrFirstCell).Resize(UBound(vntTarget)) = vntTarget
    End With
  End If
'***************************************

  Erase vntTarget

End Sub

Link to First Version