请您告知我如何能够将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
我希望这一切都有道理。
非常感谢
答案 0 :(得分：1)
无循环的解决方案：
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
答案 1 :(得分：0)
- 计算源范围并将其粘贴到源数组中。
- 在将唯一值复制到替换原始值的源数组的开头时计算唯一值的数量。
- 将唯一值写入目标数组。
- 如果启用，则将目标数组粘贴到其第一个单元格指定的目标范围内（
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
答案 2 :(得分：0)
我相信最简单的方法是使用ReDim函数：
ReDim TenACC (1 To 20)
ReDim Preserve TenACC (1 To lastRow)
我知道，使用ReDim而不是Dim声明数组非常重要，以使其正常工作