4

この式を使用して、一意のレコードを列 A から列 B にコピーします。

Range("A1", Range("A100").End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True

列 B にコピーする代わりに、フィルター処理された結果を Excel VBA の配列にどのように配置しますか?

4

7 に答える 7

7

この質問が出されてからちょうど 1 年が経ちましたが、今日同じ問題に遭遇しました。これが私の解決策です。

Function copyFilteredData() As Variant
    Dim selectedData() As Variant
    Dim aCnt As Long
    Dim rCnt As Long

    Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
    On Error GoTo MakeArray:
    For aCnt = 1 To Selection.Areas.Count
        For rCnt = 1 To Selection.Areas(aCnt).Rows.Count
            ReDim Preserve SelectedData(UBound(selectedData) + 1)
            selectedData(UBound(selectedData)) = Selection.Areas(aCnt).Rows(rCnt)
        Next
    Next

    copyFilteredData = selectedData
    Exit Function

MakeArray:
    ReDim selectedData(1)
    Resume Next

End Function

これにより、配列の要素 0 は空のままになりますが、UBound(SelectedData) は選択範囲内の行数を返します。

于 2013-08-16T09:42:26.040 に答える
1

あなたはこれを読みたくなるでしょう、そしてそれはあなたを正しい方向に向けるでしょう

それは言います：

  1. AdvancedFilter メソッドを使用して、ワークシートの未使用領域にフィルター範囲を作成します。
  2. その範囲の Value プロパティを Variant に割り当てて、2 次元配列を作成します
  3. その範囲の ClearContents メソッドを使用してそれを取り除きます
于 2012-08-16T22:05:26.817 に答える
1 
Sub tester()

    Dim arr
    arr = UniquesFromRange(ActiveSheet.Range("A1:A5"))
    If UBound(arr) = -1 Then
        Debug.Print "no values found"
    Else
        Debug.Print "got array of unique values"
    End If

End Sub


Function UniquesFromRange(rng As Range)
    Dim d As Object, c As Range, tmp
    Set d = CreateObject("scripting.dictionary")
    For Each c In rng.Cells
       tmp = Trim(c.Value)
       If Len(tmp) > 0 Then
            If Not d.Exists(tmp) Then d.Add tmp, 1
       End If
    Next c
    UniquesFromRange = d.keys
End Function
于 2012-08-16T22:15:46.810 に答える
0

以下は、列Aから情報を取得し、リストを示しています。データ入力に使用できる「Sheet3」があることを前提としています（これを変更することをお勧めします）。 

Sub test()

    Dim targetRng As Range
    Dim i As Integer

    Set targetRng = Sheets(3).Range("a1")
    Range("A1", Range("A999").End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=targetRng, Unique:=True

    Dim numbElements As Integer
    numbElements = targetRng.End(xlDown).Row
    Dim arr() As String

    ReDim arr(1 To numbElements) As String

    For i = 1 To numbElements
        arr(i) = targetRng.Offset(i - 1, 0).Value
    Next i

End Sub
于 2012-08-16T21:58:31.777 に答える