excel - 将唯一值分配给数组

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 的解决方案，因为它提供了该范围内唯一值的总数，但它不会将这些值添加到数组中。

老实说，我从 VAR 表的 E 列中获取值是在作弊，我这样做只是为了在稍后的查询中使用这些值来反对另一个数据集。虽然这有效，但代码效率非常低，因为我可能只想导出 500 个列表中 10 个值的数据，因此想要找到唯一值并运行代码的次数我有一个唯一值。我添加了完整的代码以供引用。

因此，与其从“VAR”表的 E 列分配唯一值，不如从“Sheet1”表的 A 列分配唯一值。该工作表可以包含数千行，假设 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

我相信最简单的方法是以这种方式使用函数 ReDim:

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

据我所知，使用 ReDim 而不是 Dim 声明数组以使其工作非常重要