キーワードが2、3個なら少ないので何ともないですが、

キーワードが10個や20個となると組み合わせの作業というのはめんどくさいですよね。

できればパパっとできるようにしたい方へ、

Excel さえあればだれでも簡単にできる「キーワード組み合わせ自動化」マクロをご紹介します。

Excel で「キーワード組み合わせ自動化」

今回ご紹介する「キーワード組み合わせ自動化」マクロですが２種類あります。

1. １列に記述したキーワードの組み合わせを出力
2. ２列に記述したキーワードの組み合わせを出力

１列に記述したキーワードの組み合わせを出力

これは１列にキーワードを記述し（下の左表）、そのキーワードのすべての組み合わせを出力させる（下の右表）ツールです。

作成方法

※作成する前に他の開いている Excel ファイルをすべて閉じてください。

（１）以下の画像のように Excel のレイアウトを変更します。シート名、ファイル名はなんでもいいです。

（２）Excel の「開発」→ 「Visual Basic」をクリックします。「開発」タブがない人はこちらを確認ください。

（３）「Microsoft Excel Object」を右クリックしてください。

（４）「挿入」→　「標準モジュール」をクリックします。

（５）下記画面が表示されますので赤枠の箇所に次の全てコードをコピーして貼り付けます。

コピーした内容を貼り付ける箇所 

コピーするコード （すべてコピーしてください）

' キーワード組み合わせマクロ
Sub Keywordcombination()

    Const readRow As Integer = 1 ' データの列番号
    Dim Data() As String: ReDim Data(getMaxRow(readRow) - 1)

    ' 初期化
    Call initialize(readRow)

    ' データ読み込み
    Call readData(Data, readRow)
    
    ' データ書き込み
    Call writeData(Data, readRow)
    
    ' ファイルに出力
    'Call outputFile(readRow)

End Sub

' 初期化
Private Sub initialize(readRow As Integer)
    
    Range(convertAToNum(readRow + 1) & "2:" & convertAToNum(readRow + 1) & "65536").ClearContents

End Sub

' データ読み込み
Private Sub readData(ByRef Data() As String, readRow As Integer)
    
    Dim index As Integer: index = 0
    
    If getMaxRow(readRow) = 1 Then
        MsgBox "データを入力してください"
        End
    End If
    
    For i = 1 To getMaxRow(readRow)
        Data(index) = Cells(i, readRow).Value
        index = index + 1
    Next i

End Sub

' データ書き込み
Private Sub writeData(ByRef Data() As String, readRow As Integer)
    
    Dim line As Integer: line = 1
    
    For i = 1 To UBound(Data)
        For j = i + 1 To UBound(Data)
           If Data(i) <> Data(j) Or Data(i) <> "" Or Data(j) <> "" Then
                line = line + 1
                Cells(line, readRow + 1).Value = Data(i) & " " & Data(j)
            End If
        Next j
    Next i

End Sub

' データ書き込み
Private Sub outputFile(readRow As Integer)
    
    Dim outputword As String: outputword = ""
    Dim fname As String: fname = printDialog()
    
    If fname <> "" Then
        For i = 2 To getMaxRow(readRow + 1)
            If i = 2 Then
                outputword = Cells(i, readRow + 1).Value
            Else
                outputword = outputword & "," & Cells(i, readRow + 1).Value
            End If
        Next i
        Open fname For Output As #1
        Print #1, outputword
        MsgBox "ファイルに出力されました。"
        Close #1
    End If
    
End Sub

' ファイル選択用ダイヤログ表示
Function printDialog()
    
    Dim fname As Variant
    
    fname = Application.GetSaveAsFilename( _
            InitialFileName:="test.txt", _
            filefilter:="テキストファイル,*.txt", _
            Title:="ファイル保存")
    
    If VarType(fname) = vbBoolean Then
        MsgBox "キャンセルされました。"
        printDialog = ""
    Else
        printDialog = fname
    End If
    
End Function

' 最終行番号
Function getMaxRow(row As Integer) As Integer
    getMaxRow = Range(convertAToNum(row) & "65536").End(xlUp).row
End Function

' 列番号変換 アルファベット → 数値
Function convertAToNum(ByVal num As Long) As String
    
    tmp = Cells(1, num).Address(True, False)
    convertAToNum = Left(tmp, InStr(tmp, "$") - 1)

End Function

（６）画面を閉じてさっきの Excel 画面に戻ります。①キーワードを A 列に入力し ②「開発」→「マクロ」とクリックします。

※ キーワードは必ず A 列２行目から入力してください。１行目にキーワードを入れても組み合わせには出力されません。

（７）「KeyWordcombination」を選択し、「実行」をクリックします。

（８）B列目にキーワードの組み合わせが表示されます。

簡単ですね！以上になります。

２列に記述したキーワードの組み合わせを出力

２列のキーワードの組み合わせを自動で行う方法を紹介します。

作成方法

（１）新しく Excel を開いてください。そして下記画面のようにレイアウトを作成してください。シート名、ファイル名はなんでもいいです。

（２）このページの「１列に記述したキーワードの組み合わせを出力」で解説しました手順（２）～（５）と同様に行います。そして下記画面に以下のコードをすべてコピーして張り付けます。

コピーした内容を貼り付ける箇所 

コピーするコード （すべてコピーしてください）

' キーワード組み合わせマクロ
Sub MultiKeywordcombination()

    Dim Data1() As String: ReDim Data1(getMaxRow(1) - 2)
    Dim Data2() As String: ReDim Data2(getMaxRow(2) - 2)
    Dim afterData() As String: ReDim afterData(sumData())
    
    ' 初期化
    Call initialize

    ' データ読み込み
    Call readData(Data1, Data2)
    
    ' データ書き込み
    Call writeData(Data1, Data2, afterData)
    
    ' ファイルに出力
    'Call outputFile(afterData)

End Sub

' 初期化
Private Sub initialize()
    
    Range("C2:C65536").ClearContents

End Sub

' データ読み込み
Private Sub readData(ByRef Data1() As String, ByRef Data2() As String)
    
    ' A 列目
    Call inputVal(Data1, 1)
     ' B 列目
    Call inputVal(Data2, 2)
    
End Sub

' データ書き込み
Private Sub writeData(ByRef Data1() As String, ByRef Data2() As String, ByRef afterData() As String)
        
        Dim i As Integer
        Dim j As Integer
        Dim index As Integer: index = 0
        
        For i = 0 To UBound(Data1)
            For j = 0 To UBound(Data2)
                If Len(Data1(i)) <> 0 And Len(Data2(j)) <> 0 Then
                    afterData(index) = Data1(i) & " " & Data2(j)
                   Cells(index + 2, 3).Value = afterData(index)
                    index = index + 1
                End If
            Next j
        Next i
End Sub

' ファイルに出力
Private Sub outputFile(ByRef afterData() As String)
    
    Dim outputword As String
    Dim fname As String: fname = printDialog()
    
    If fname <> "" Then
        Open fname For Output As #1
        For i = 0 To UBound(afterData) - 1
            If i = 0 Then
                outputword = afterData(i)
            ElseIf i = UBound(afterData) - 1 Then
                outputword = outputword & "," & afterData(i)
            Else
                outputword = outputword & "," & afterData(i) & ","
            End If
        Next i
        Print #1, outputword
        MsgBox "ファイルに出力されました。"
        Close #1
    End If
    
End Sub

' ファイル選択用ダイヤログ表示
Function printDialog()
    
    Dim fname As Variant
    
    fname = Application.GetSaveAsFilename( _
            InitialFileName:="test.txt", _
            filefilter:="テキストファイル,*.txt", _
            Title:="ファイル保存")
    
    If VarType(fname) = vbBoolean Then
        MsgBox "キャンセルされました。"
        printDialog = ""
    Else
        printDialog = fname
    End If
    
End Function

' 変数に値を格納
Private Sub inputVal(ByRef Data() As String, ByVal col As Integer)
    
    Dim i As Integer
    Dim index As Integer: index = 0
    
    ' A 列目
    For i = 2 To getMaxRow(col)
        Data(index) = Cells(i, col).Value
        index = index + 1
    Next i
    index = 0
    
End Sub

' 合計データ数
Function sumData() As Integer
    
    Dim i As Integer
    Dim sum As Integer: sum = 1
    
    For i = 1 To getMaxCol()
        sum = sum * getMaxRow(i)
    Next i
    
    sumData = sum

End Function

' 最終行番号
Function getMaxRow(row As Integer) As Integer
    getMaxRow = Range(convertAToNum(row) & "65536").End(xlUp).row
End Function

' 最終列番号
Function getMaxCol() As Integer
    getMaxCol = Range("IV1").End(xlToLeft).Column
End Function

' 列番号変換 アルファベット → 数値
Function convertAToNum(ByVal num As Long) As String
    tmp = Cells(1, num).Address(True, False)
    convertAToNum = Left(tmp, InStr(tmp, "$") - 1)
End Function

（３）画面を閉じてさっきの Excel 画面に戻ります。①キーワードを A 列とB 列に入力し ②「開発」→「マクロ」とクリックします。

※ キーワードは必ず A 列とB 列の２行目から入力してください。１行目にキーワードを入れても組み合わせには出力されません。

（４）「MultiKeyWordcombination」を選択し、「実行」をクリックします。

（５）C 列に A 列 と B 列 のキーワードが出力されます。

以上です。これもすぐにできると思います。

最後に

最後までご精読ありがとうございました。

なお今回コピーして貼り付けたコードにはファイル出力機能もあります。

もしファイル出力機能をつけたいのなら貼り付けるコードの以下の箇所の先頭にある「’」（シングルクォーテーション）を外して貼り付けてください。

（変更前）'Call outputFile(afterData) 

（変更後）Call outputFile(afterData)