Question

我想在D列中查看一系列值并获取每个值：

检查其出现的相同范围
在其出现的行中检查A列中的值
将列a中的此值添加到数组（或另一种保存数据的方式）
转到D列中下一个值，并将列A的下一个值保存到数组
当我检查所有出现的每个值并将其添加到数组时，我希望在单元格H1中给出数组（对于下一个值，I1等等）

这是我对一些虚拟值的意思：

到目前为止，我在VBA中的尝试是这样的（我第一次处理数组的说法）：

while True:
    p = self.win.getMouse()
    if not p:
       break
help_screen.undraw()
help_title.undraw()
[rule.undraw() for rule in rules]

不幸的是，我已收到以下错误消息：

Dim finden As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim i As Integer
Dim zahl As Integer
Dim zeile As Range
Dim temparray As Double
Dim b As Integer
Dim count As Integer

Set rng = Worksheets("Tabelle1").Range("H1:H100")
i = Worksheets("Tabelle1").Cells(Rows.count, "D").End(xlUp).Row

For zahl = 1 To i
finden = Sheets("Tabelle1").Cells(zahl, "D").Value
count = Application.WorksheetFunction.CountIf(Range("A1:A100"), finden)
Set zeile = Sheets("Tabelle1").Columns("D").Find(finden, Cells(Rows.count, "D"), xlValues, xlWhole)
If Not zeile Is Nothing Then
    FoundCell = zeile.Address
    Do
        For b = 1 To count
        Set temparray(b, 1) = Sheets("Tabelle1").Cells(zeile.Row, "A").Value
        Set zeile = Sheets("Tabelle1").Columns("A").Find(finden, zeile, xlValues, xlWhole)
        Next b
    Loop While zeile.Address <> FoundCell
   End If
Set zeile = Nothing
rng.Value = temparray
Sheets("Tabelle1").Cells(1, 8 + zahl) = rng.Value
Next

End Sub

告诉我一个数据字段是预期的。

知道如何解决我的问题吗？

Answer 1

查看Collection对象，因为它是存储唯一值的好方法。您不需要运行多个Find函数或逐步构建数组，只需读取一次列并将其写入相关集合即可。

必须从您的问题和代码中说出您想要如何编写输出，但下面的代码将为您指明正确的方向：

Dim uniques As Collection
Dim valueSet As Collection
Dim valueD As String
Dim valueA As String
Dim v As Variant
Dim r As Long
Dim c As Long
Dim output() As String

'Read the data
With ThisWorkbook.Worksheets("Tabelle1")
    v = .Range("A1", _
        .Cells(Rows.Count, "D").End(xlUp)) _
        .Value2
End With

'Populate the collections
Set uniques = New Collection
For r = 1 To UBound(v, 1)

    valueA = CStr(v(r, 1))
    valueD = CStr(v(r, 4))

    'Check if we have a collection for the D value
    Set valueSet = Nothing
    On Error Resume Next
    Set valueSet = uniques(valueD)
    On Error GoTo 0

    'If not then create a new one.
    If valueSet Is Nothing Then
        Set valueSet = New Collection
        uniques.Add valueSet, Key:=valueD
    End If

    'Add the A value to it
    valueSet.Add valueA
Next

'Compile the write array
ReDim Preserve output(1 To 1, 1 To uniques.Count)
c = 1
For Each valueSet In uniques
    For Each v In valueSet
        '--> uncomment this 'If block', if you want
        '--> comma separated values.
'            If Len(output(1, c)) > 0 Then
'                output(1, c) = output(1, c) & ", "
'            End If
        output(1, c) = output(1, c) & v
    Next
    c = c + 1
Next

'Write the output array
ThisWorkbook.Worksheets("Tabelle1") _
    .Range("H1").Resize(, UBound(output, 2)) _
    .Value = output

遍历范围中的值，在范围内搜索它们，在相应行中查找值，将它们添加到数组中

1 个答案: