Excel VBA 逆引き集 | 抽出用の一意リスト

Excel VBA
スポンサーリンク

抽出用の一意リスト

抽出やフィルタ、ドロップダウン（入力規則）の元ネタに使う「重複なしの一意リスト」を、元表を壊さず安全に作るテンプレをまとめました。初心者でも使えるように、最短版から柔軟版、複合キー、ドロップダウン連携まで一気にいきます。

共通ユーティリティ（速度・正規化・出力）

Option Explicit

Private Sub SpeedOn()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Private Sub SpeedOff()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function NormKey(ByVal v As Variant) As String
    NormKey = UCase$(Trim$(CStr(v))) ' 前後空白除去＋大文字化
End Function

Private Function EnsureSheet(ByVal name As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = name
    End If
    If clear Then ws.Cells.Clear
    Set EnsureSheet = ws
End Function
VB
  • 速度最適化: 画面更新・イベント・計算を止める→最後に戻す。
  • キー正規化: 表記揺れを吸収（空白・大小文字）。必要なら全角→半角も追加可能。
  • 安全出力: 必ず別シートへ出力し、元表は非破壊。

基本テンプレ：単一列から一意リスト抽出（元表を壊さない）

「Data」シートのA列（見出しあり）から一意リストを別シート「一意リスト」に出力。

Sub UniqueList_SingleColumn()
    SpeedOn

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim r As Long, k As String
    For r = 2 To lastRow
        k = NormKey(ws.Cells(r, "A").Value)
        If Len(k) > 0 Then If Not dict.Exists(k) Then dict(k) = True
    Next

    Dim out As Worksheet: Set out = EnsureSheet("一意リスト", True)
    out.Range("A1").Value = "A列の一意値"
    Dim i As Long: i = 2
    Dim key As Variant
    For Each key In dict.Keys
        out.Cells(i, 1).Value = key
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "単一列の一意リストを作成しました。件数: " & i - 2
End Sub
VB
  • 使いどころ: フィルタ候補の準備、ドロップダウンのリスト作成、検索キー一覧など。
  • コツ: 空値は除外。正規化で「abc」「ABC」「abc 」を同一扱い。

見出し名で列指定（列順に強い）＋複数列同時抽出

「Data」シートの任意の見出し名から列番号を特定し、一意リストを複数列で並べて出力。

Private Function FindHeader(ByVal headerRow As Range, ByVal name As String) As Long
    Dim hit As Range
    Set hit = headerRow.Find(What:=name, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    FindHeader = IIf(hit Is Nothing, 0, hit.Column)
End Function

Sub UniqueList_ByHeaders()
    SpeedOn

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    ' 欲しい見出し（例：カテゴリ・担当者・コード）
    Dim headers As Variant: headers = Array("カテゴリ", "担当者", "コード")
    Dim i As Long, cols() As Long: ReDim cols(LBound(headers) To UBound(headers))
    For i = LBound(headers) To UBound(headers)
        cols(i) = FindHeader(rg.Rows(1), headers(i))
        If cols(i) = 0 Then SpeedOff: MsgBox "見出しがありません: " & headers(i): Exit Sub
    Next

    ' 辞書に各列の一意セットを保持
    Dim dicts() As Object: ReDim dicts(LBound(headers) To UBound(headers))
    For i = LBound(headers) To UBound(headers)
        Set dicts(i) = CreateObject("Scripting.Dictionary")
    Next

    Dim r As Long, k As String
    For r = 2 To UBound(v, 1)
        For i = LBound(headers) To UBound(headers)
            k = NormKey(v(r, cols(i)))
            If Len(k) > 0 Then If Not dicts(i).Exists(k) Then dicts(i)(k) = True
        Next
    Next

    Dim out As Worksheet: Set out = EnsureSheet("一意リスト_複数列", True)
    ' 見出し
    For i = LBound(headers) To UBound(headers)
        out.Cells(1, i + 1).Value = headers(i) & "の一意値"
    Next

    ' 行方向に最大件数に合わせて出力
    Dim rowPtr As Long: rowPtr = 2
    Dim maxLen As Long
    For i = LBound(headers) To UBound(headers)
        If dicts(i).Count > maxLen Then maxLen = dicts(i).Count
    Next

    Dim idx As Long
    For idx = 0 To maxLen - 1
        For i = LBound(headers) To UBound(headers)
            If idx < dicts(i).Count Then
                out.Cells(rowPtr, i + 1).Value = dicts(i).Keys()(idx)
            End If
        Next
        rowPtr = rowPtr + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "見出し指定の一意リストを出力しました。最大列件数: " & maxLen
End Sub
VB
  • 使いどころ: 抽出条件の原本（カテゴリ一覧、担当者一覧など）を列ごとに一気に作る。
  • コツ: 列順が変わっても壊れない。見出し名を使うのが実務向き。

複合キーの一意リスト（コード×月など）

月次抽出用などに「コード|yyyy-mm」のキーで一意化し、分解して出力。

Sub UniqueList_CompositeKey_CodeMonth()
    SpeedOn

    Dim rg As Range: Set rg = Worksheets("Data").Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    ' 列想定：A=コード、B=日付
    Dim cCode As Long: cCode = 1
    Dim cDate As Long: cDate = 2

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim r As Long, code As String, ym As String
    For r = 2 To UBound(v, 1)
        If Len(Trim$(CStr(v(r, cCode)))) = 0 Or Not IsDate(v(r, cDate)) Then GoTo cont
        code = NormKey(v(r, cCode))
        ym = Format$(CDate(v(r, cDate)), "yyyy-mm")
        If Not dict.Exists(code & "|" & ym) Then dict(code & "|" & ym) = True
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("一意リスト_コード月", True)
    out.Range("A1:C1").Value = Array("コード", "年月", "複合キー")

    Dim i As Long: i = 2
    Dim key As Variant, parts() As String
    For Each key In dict.Keys
        parts = Split(CStr(key), "|")
        out.Cells(i, 1).Value = parts(0)
        out.Cells(i, 2).Value = parts(1)
        out.Cells(i, 3).Value = key
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "コード×月の一意リストを作成しました。件数: " & i - 2
End Sub
VB
  • 使いどころ: 月次抽出・グループ別抽出。複合キーでユニーク化してから抽出条件に使う。

ドロップダウン（入力規則）に一意リストを接続

一意リストを「抽出条件セル」のドロップダウンに設定して、ミス入力を防止。

Sub BindUniqueList_ToValidation()
    SpeedOn

    ' 先に UniqueList_SingleColumn を実行して「一意リスト」シートにA2:Aの一覧がある前提
    Dim wsList As Worksheet: Set wsList = Worksheets("一意リスト")
    Dim lastRow As Long: lastRow = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row
    If lastRow < 2 Then SpeedOff: MsgBox "一意リストがありません": Exit Sub

    ' 抽出条件セル（例：Sheet「Query」のB2）
    Dim wsQ As Worksheet: Set wsQ = EnsureSheet("Query", False)
    With wsQ.Range("B2").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
             Formula1:="='一意リスト'!$A$2:$A$" & lastRow
        .InputTitle = "選択"
        .InputMessage = "一意リストから選んでください"
        .ErrorTitle = "入力エラー"
        .ErrorMessage = "一覧から選択してください"
    End With

    SpeedOff
    MsgBox "ドロップダウンへ一意リストを接続しました"
End Sub
VB
  • 使いどころ: 抽出条件の入力ミス防止、安定した検索キー運用。
  • コツ: 一意リストを更新したら、バリデーション範囲は動的に拡張されるように最後行を取り直す。

例題で練習

'例1：A列から一意リストを作る
Sub Example_UniqueSingle()
    UniqueList_SingleColumn
End Sub

'例2：見出し名指定（カテゴリ・担当者・コード）の一意リストを列ごとに作る
Sub Example_UniqueHeaders()
    UniqueList_ByHeaders
End Sub

'例3：コード×月（yyyy-mm）の複合キーで一意リスト
Sub Example_UniqueCodeMonth()
    UniqueList_CompositeKey_CodeMonth
End Sub

'例4：一意リストをドロップダウンに接続
Sub Example_BindValidation()
    BindUniqueList_ToValidation
End Sub
VB

実務の落とし穴と対策

  • 表記揺れで別物扱いになる
    • 対策: 正規化: 前後空白・大小文字の統一。必要なら全角→半角も。
  • 列順変更で壊れる
    • 対策: 見出し検索: Findで列特定、ハードコードを避ける。
  • 日付の文字列/数値混在
    • 対策: Date型化: CDateで型を揃え、出力でFormat。
  • 元表を汚したくない
    • 対策: 別シート出力: 常に非破壊運用。更新は作り直しでOK。
  • 大量データで遅い
    • 対策: 配列＋辞書＋SpeedOn/Off: 読み込み一括・存在判定高速。
スポンサーリンク
タイトルとURLをコピーしました