Excel VBA 逆引き集 | 未入力行の抽出

Excel VBA
スポンサーリンク

未入力行の抽出

「空白行だけ抜きたい」「必須項目が未入力の行だけ抽出したい」—初心者でもすぐ使える4つの定番アプローチを、落とし穴対策込みでまとめました。単一列の空白から、複数列の必須チェック、見た目の空白（スペースのみ）まで対応します。

最短：AutoFilterで空白抽出（単一列）

Sub Extract_Blanks_AutoFilter_OneColumn()
    With Range("A1").CurrentRegion
        .AutoFilter Field:=1, Criteria1:="="          'A列が空白の行だけ表示
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
        .AutoFilter                                   '解除
    End With
End Sub
VB
  • ポイント:
    • “=“ は空白条件。見出しを含む表（CurrentRegion）を前提に最短で動く。
    • スペースやタブが入っている「見た目空白」は抽出されないため、後述の「スペース除去」を併用。

定番：ループ＋Ifで柔軟判定（複数列の必須チェック）

Sub Extract_Blanks_MultiRequired()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim last As Long: last = rg.Row + rg.Rows.Count - 1
    Dim out As Worksheet: Set out = Worksheets("抽出")
    Dim outRow As Long: outRow = 2

    Dim r As Long
    For r = rg.Row + 1 To last                   'ヘッダーを除く
        Dim nameVal As String, qtyVal As String, priceVal As String
        nameVal = Trim$(CStr(Cells(r, "A").Value))   '必須1：商品名
        qtyVal = Trim$(CStr(Cells(r, "B").Value))    '必須2：数量
        priceVal = Trim$(CStr(Cells(r, "C").Value))  '必須3：単価

        'どれか未入力（空文字）なら抽出
        If nameVal = "" Or qtyVal = "" Or priceVal = "" Then
            Rows(r).Copy Destination:=out.Rows(outRow)
            outRow = outRow + 1
        End If
    Next
End Sub
VB
  • ポイント:
    • Trimで前後の空白・改行を除去してから判定。スペースだけの「見た目空白」も未入力扱いになる。
    • 必須列が増えてもOr条件に足すだけで拡張可能。

爆速：配列で一括チェック→まとめて貼り付け

Sub Extract_Blanks_ArrayFast()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value                   '表丸ごと配列へ
    Dim rowsHit As Object: Set rowsHit = CreateObject("Scripting.Dictionary")

    Dim i As Long
    For i = 2 To UBound(v, 1)                        '2行目から（ヘッダー除外）
        Dim nameVal As String, qtyVal As String, priceVal As String
        nameVal = Trim$(CStr(v(i, 1)))
        qtyVal = Trim$(CStr(v(i, 2)))
        priceVal = Trim$(CStr(v(i, 3)))
        If nameVal = "" Or qtyVal = "" Or priceVal = "" Then
            rowsHit(i) = True
        End If
    Next

    If rowsHit.Count > 0 Then
        Dim out() As Variant, cnt As Long: cnt = rowsHit.Count
        ReDim out(1 To cnt, 1 To UBound(v, 2))

        Dim idx As Variant, rOut As Long: rOut = 1
        For Each idx In rowsHit.Keys
            Dim c As Long
            For c = 1 To UBound(v, 2)
                out(rOut, c) = v(idx, c)
            Next
            rOut = rOut + 1
        Next

        Worksheets("抽出").Range("A1").Resize(1, UBound(v, 2)).Value = rg.Rows(1).Value 'ヘッダー
        Worksheets("抽出").Range("A2").Resize(cnt, UBound(v, 2)).Value = out
    End If

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • セル往復を避けて高速。10万行規模でも耐える。
    • 必須列の位置は v(i, 列番号) で自在に設定できる。

1列だけの本当に空白セルを拾う（SpecialCells）

Sub Extract_Blanks_SpecialCells()
    Dim col As Range: Set col = Range("A2:A100000") '対象列
    On Error Resume Next
    Dim blanks As Range: Set blanks = col.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not blanks Is Nothing Then
        '空白セルの行を丸ごと抽出へコピー
        Dim c As Range, out As Worksheet: Set out = Worksheets("抽出")
        Dim outRow As Long: outRow = 2
        For Each c In blanks
            Rows(c.Row).Copy Destination:=out.Rows(outRow)
            outRow = outRow + 1
        Next
    End If
End Sub
VB
  • ポイント:
    • 真の空白セルのみ対象。スペースや関数の空文字（””）は含まれないことがあるため、用途に応じて選ぶ。

スペースのみ・関数の空文字も「未入力」扱いにする

Sub NormalizeSpaces_ThenExtract()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim last As Long: last = rg.Row + rg.Rows.Count - 1

    '対象列の前処理：スペース・改行を削除してから空白判定（A～C列例）
    Dim r As Long, cols As Variant: cols = Array("A", "B", "C")
    For r = rg.Row + 1 To last
        Dim k As Long
        For k = LBound(cols) To UBound(cols)
            With Cells(r, cols(k))
                .Value = Trim$(Replace(Replace(CStr(.Value), vbCrLf, " "), vbTab, " "))
            End With
        Next
    Next

    '前処理後は AutoFilter の空白抽出が効きやすい
    With Range("A1").CurrentRegion
        .AutoFilter Field:=1, Criteria1:="="
        .AutoFilter Field:=2, Criteria1:="="
        .AutoFilter Field:=3, Criteria1:="="
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
        .AutoFilter
    End With
End Sub
VB
  • ポイント:
    • 改行・タブ・スペースを正規化して「実質空白」に。関数で “” を返している場合は値化が必要なこともある。

ラベル未入力の行を抽出（ヘッダー別名にも対応）

Sub Extract_Blanks_ByHeaderNames()
    Dim head As Range: Set head = Range("A1").CurrentRegion.Rows(1)
    Dim colName As Long, colQty As Long, colPrice As Long

    colName = GetColumnByHeader("商品名", head)
    colQty  = GetColumnByHeader("数量", head)
    colPrice= GetColumnByHeader("単価", head)
    If colName * colQty * colPrice = 0 Then
        MsgBox "必要な見出しが見つかりません": Exit Sub
    End If

    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value
    Dim rowsHit As Object: Set rowsHit = CreateObject("Scripting.Dictionary")

    Dim i As Long
    For i = 2 To UBound(v, 1)
        If Trim$(CStr(v(i, colName))) = "" Or _
           Trim$(CStr(v(i, colQty)))  = "" Or _
           Trim$(CStr(v(i, colPrice)))= "" Then
           rowsHit(i) = True
        End If
    Next

    If rowsHit.Count > 0 Then
        Dim out() As Variant, cnt As Long: cnt = rowsHit.Count
        ReDim out(1 To cnt, 1 To UBound(v, 2))
        Dim idx As Variant, rOut As Long: rOut = 1
        For Each idx In rowsHit.Keys
            Dim c As Long
            For c = 1 To UBound(v, 2)
                out(rOut, c) = v(idx, c)
            Next
            rOut = rOut + 1
        Next
        Worksheets("抽出").Range("A1").Resize(1, UBound(v, 2)).Value = rg.Rows(1).Value
        Worksheets("抽出").Range("A2").Resize(cnt, UBound(v, 2)).Value = out
    End If
End Sub

Function GetColumnByHeader(ByVal headerName As String, ByVal headerRange As Range) As Long
    Dim hit As Range
    Set hit = headerRange.Find(What:=headerName, LookAt:=xlWhole, LookIn:=xlValues)
    GetColumnByHeader = IIf(hit Is Nothing, 0, hit.Column)
End Function
VB
  • ポイント:
    • 見出しの名称が変わる現場でも壊れにくい。見出し→列番号を動的に取得。

安全・高速ラップ（大量時の基本）

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

Sub SafeWrapEnd()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • 前後停止→復帰で体感が大きく改善。エラー時も復帰できるよう On Error GoTo Cleanup を併用。

よくある落とし穴と対策

  • スペースだけ・改行だけで「空白じゃない」に見える
    • 対策: Trim＋Replaceで前処理してから判定。タブや改行も消す。
  • 関数の空文字（””）は空白扱いにならないことがある
    • 対策: 値化（.Value = .Value）や前処理で文字列化→Trim判定へ。
  • AutoFilter対象の列選択ミス
    • 対策: CurrentRegionを使うか、ヘッダー位置をFindで動的に取得。
  • セル往復で遅い
    • 対策: 範囲→配列へ読み込み、まとめて判定→一括貼り付け。
  • 「必須列」の定義変更でコードが壊れる
    • 対策: 見出し→列番号の動的取得（GetColumnByHeader）で耐久性を確保。

例題で練習

'例1：A列が空白の行だけ抽出
Sub Example_OneColumnBlank()
    With Range("A1").CurrentRegion
        .AutoFilter Field:=1, Criteria1:="="
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
        .AutoFilter
    End With
End Sub

'例2：商品名/数量/単価のいずれかが未入力の行を抽出（Trim込み）
Sub Example_MultiRequiredBlank()
    Call Extract_Blanks_ArrayFast  '本文の高速テンプレをそのまま使用
End Sub

'例3：SpecialCellsで「真の空白セル」行だけ抽出（A列）
Sub Example_SpecialCellsBlank()
    Call Extract_Blanks_SpecialCells
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました