Назначьте уникальные значения в массив

Question

Подскажите, пожалуйста, как я могу назначить уникальные значения в столбце E и количество уникальных значений в столбце E в массив.

    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

Я ценю, что «Dim TenAcc (1 To 20) As String» является массивом, но я не уверен, как разместить значение из lastRow, где в данный момент находится 20.Я пробовал различные методы для преобразования

Я также знаю, что оператор lastRow подсчитывает общее, а не общее уникальное значение, это только для меня, чтобы проверить.

Я сделалмного чтения и тестирования, проще говоря, мои знания или понимание просто недостаточно хороши для решения проблемы.

Буду признателен за любые советы

Спасибо

Плюсы

Меня попросили предоставить больше информации, поэтому здесь идет;

Большое спасибо за все ваши предложения, мне особенно нравится решение EvR, поскольку оно предоставило общее количество уникальных значений в диапазоне, однако оно делаетне добавляйте эти значения в массив.

Если честно, я обманываю, беря значения из столбца E таблицы VAR, я делаю это только для того, чтобы использовать эти значения для аргументации против других данных.установить позже в запросе.Хотя это работает, код очень неэффективен, так как я могу захотеть экспортировать данные только для 10 значений в списке из 500, следовательно, хочу найти уникальные значения и выполнить код столько раз, сколько у меня будет уникального значения.Я добавил полный код для справочных целей.

Поэтому вместо присвоения уникальных значений из столбца E на листе «VAR» они должны исходить из столбца A на листе «Лист1».Этот лист может содержать тысячи строк, скажем, для 10 уникальных клиентов, и поэтому мне нужно создать 10 отдельных файлов, т.е. выполнить цикл 10 раз.В настоящее время я запускаю его столько раз, сколько у нас потенциальных клиентов, хотя я установил его на 20 для тестирования, на самом деле это сотни, что делает код неэффективным для запуска, это работает, но это не главное.

    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

Надеюсь, все это имеет смысл.

Большое спасибо

Answer 1

Range, Array, Array (, Range)

Highlights

• Рассчитывает исходный диапазон и вставляет его в исходный массив.
• Рассчитываетколичество уникальных значений при копировании их в начало исходного массива, заменяя исходные значения.
• Записывает уникальные значения в целевой массив.
• Дополнительно вставляет целевой массив в целевой диапазон, заданный параметромпервая ячейка, если она включена (cBlnPaste = True).

Код

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

Ссылка на первую версию

Answer 2

Я считаю, что самый простой способ - использовать функцию ReDim следующим образом:

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

Как я знаю, очень важно объявить массив с помощью ReDim, а не Dim, чтобы он работал

Answer 3

решение без зацикливания:

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