1

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

Improve this question
4
  • 3
    Not sure what the question is but you're probably better off when you use a dictionary Commented Dec 6, 2018 at 8:59
  • 1
    Also you can assign a range to an array without a loop TenAcc = .Range("E2").Resize(lastRow).Value. Commented Dec 6, 2018 at 9:43
  • 1
    You can paste your range (column E of the UsedRange) into a source array, then check the data for unique values writing them into a target array. Not sure where you wanna put the count of unique values and what to do with the target array. If you could elaborate a bit more. And don't you have headers? Commented Dec 6, 2018 at 10:23
  • 1
    You can use ReDim to change the size of an array based on a Variable (Dim TenAcc() As String: ReDim TenAcc(1 To lastRow)), or ReDim Preserve to change the size without deleting data already in the Array. You can also use WorksheetFunction.CountIf with an Array to check if a value is in it like you would a Range Commented Dec 6, 2018 at 11:11

3 Answers 3

Reset to default
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

Improve this answer
Sign up to request clarification or add additional context in comments.

1 Comment

You can declare the Array using Dim, and then ReDim it afterwards, but you have to make sure the original declaration is Unsized (Dim TenACC() As String instead of DIM TenACC(1 to 20) As String)
1

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

Improve this answer

Comments

1

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
Improve this answer

4 Comments

Just a hint to internationalization: The search string parameter "False" in the Filter() function has to be defined due to regional Settings in other languages, eg. changing to "Falsch" in German. - BTW A refreshing escape from monotony of "Get me my uniques" questions and answers +1)
I put the False within "" because the filter function search for strings, but I think it will work without quotes even better. I'll edit my answer, thanks!
Hi Both, i really like this as it does give me a count, but it does not assign the unique values to the array to use later? I have added a fuller explanation to the bottom of my original post. Thanks
TenAcc contains the unique values, if you want to store this for later use, you could declare public TenAcc() As String at the top of your module outside the Sub

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.