Excel VBA – 一覧の操作をするサンプル

ExcelVBAで一覧を操作するサンプルです。

  1. キーワードを手入力します
  2. 実行する操作をドロップダウンリストから選択します
  3. 実行ボタンをクリックします

操作を「抽出」で実行した場合、上記のように抽出対象のF列に、A1セルで設定した「世田谷」という文字を含む行をフィルタします。

Option Explicit

Sub clickSubmit()

Dim strThisbook         As String
Dim strSheet            As String
Dim strKeyword          As String
Dim strAction           As String
Dim lngRowNmbr          As Long
Dim lngRowNmbr2         As Long
Dim lngRowNmbrM         As Long

    strThisbook = ThisWorkbook.Name
    strSheet = ActiveSheet.Name
    strKeyword = Workbooks(strThisbook).Sheets(strSheet).Range("A1")
    strAction = Workbooks(strThisbook).Sheets(strSheet).Range("C1")
    
    If strAction = "抽出" Then
        ' 最終行をもとめます
        lngRowNmbr = Workbooks(strThisbook).Sheets(strSheet) _
            .Cells(Workbooks(strThisbook).Sheets(strSheet).Rows.Count, 1) _
            .End(xlUp)
        ' フィルタがかかっている場合削除します
        If Workbooks(strThisbook).Sheets(strSheet).AutoFilterMode = True Then
            Workbooks(strThisbook).Sheets(strSheet) _
                .Range("A2:DE" & lngRowNmbr).AutoFilter
        End If
        ' フィルタをかけます
        Selection.AutoFilter
             ActiveSheet.Range("$A$2:$DE$" & lngRowNmbr) _
                .AutoFilter Field:=6, Criteria1:="=*" & strKeyword & "*"
    ElseIf strAction = "削除" Then
        ' 削除対象の行を選んで削除します
        lngRowNmbr = 3
        Do While Workbooks(strThisbook).Sheets(strSheet) _
            .Cells(lngRowNmbr, 1) <> ""
            If InStr(1, Workbooks(strThisbook).Sheets(strSheet) _
                .Cells(lngRowNmbr, 6), strKeyword) > 0 Then
                Workbooks(strThisbook).Sheets(strSheet).Rows(lngRowNmbr) _
                    .Delete
                lngRowNmbr = lngRowNmbr - 1
            End If
            lngRowNmbr = lngRowNmbr + 1
        Loop
    ElseIf strAction = "コピー" Then
        ' 最終行をもとめます
        lngRowNmbrM = Workbooks(strThisbook).Sheets(strSheet) _
            .Cells(Workbooks(strThisbook).Sheets(strSheet).Rows.Count, 1) _
            .End(xlUp)
        ' コピー対象の行を選んでコピーします
        lngRowNmbr = 3
        lngRowNmbr2 = lngRowNmbrM + 1
        For lngRowNmbr = 3 To lngRowNmbrM
            Do While Workbooks(strThisbook).Sheets(strSheet) _
                .Cells(lngRowNmbr2, 1) <> ""
                lngRowNmbr2 = lngRowNmbr2 + 1
            Loop
            If InStr(1, Workbooks(strThisbook).Sheets(strSheet) _
                .Cells(lngRowNmbr, 6), strKeyword) > 0 Then
                Workbooks(strThisbook).Sheets(strSheet) _
                    .Rows(lngRowNmbr).Select
                Selection.Copy
                Workbooks(strThisbook).Sheets(strSheet) _
                    .Rows(lngRowNmbr2).Select
                ActiveSheet.Paste
                lngRowNmbr2 = lngRowNmbr2 + 1
            End If
        Next lngRowNmbr
    End If
End Sub

サンプルなのに思ったより長くなって焦るやつ（ｱｾ

VBA

Posted by SNOW