【VBA】リスティング用KW掛け合わせツール
- uniteen
- 2015年8月22日
- 読了時間: 5分
合宿にいく合間で更新作業。
表題、なかなか便利なツールを作成いたしました。
リスティングにおけて、KW作成に関してはキモと呼んでいい項目だとは思いますが、
以外と色んなパターンを用意するのは時間がかかります。
そこをどれだけアシストできるかに注力して作成いたしました。
①、メインキーワードと複数のサブキーワードの掛け合わせ
②、メインキーワードに+をつけたもの
③、①の完全一致
④、①のフレーズ一致
⑤、①の前後入れ替え
⑥、⑤の完全一致
⑦、⑥の完全一致
上記７点を一発で出力します。
チェックボックスで選択も可能です。
セルの間に空白ができても問題ありません。
広告グループを最初に考えて、適当にキーワードをちりばめてもらえれば、その列に存在する
すべてのKWをメインキーワードと掛け合わせます。
隣のシートに結果を反映、今までの記録の最終行にどんどん追加していくことが
できます、コピー、リセットボタンもつけました。
チェックボックスに関しては、下のセルに結果をリンクすることで、
ユーザーフォームでVBAを組まなくても大丈夫にしました。
また今度ユーザーフォームでチェックボックスの値をリンクさせる方式も
ご紹介します。
【スクリプトの解説】
そのままスクリプトとして貼り付けても使えるように、
今後はコメントアウトとして解説を書き込んでいきます。
Public data, result
Public LastRow, LastColumn
'パブリックで全体で使える変数を指定します。
'まぁ本当はLastRowみたいに全体で数値を入れ替えまくるパブリック変数は悪い使い方です。
'もっと複雑な処理をすると、どこの処理でどの変数をいれた状態かわからなくなります。
'今回は、最終行と最終列という概念を多く使うので、手間の削減と目視でわかりやすいように
'するため、使いました。
Sub KW出力()
Dim i, j
Set data = Worksheets("データ")
Set result = Worksheets("出力結果")
Application.ScreenUpdating = False
'処理画面を固定するメソッドです。
result.Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range(Range("A3"), Range("C" & LastRow)).Clear
data.Select
'今回のキモとなるメソッドです。
'Range(Range("A3"), Range("C" & LastRow)).Clear
'A3から、Aの最終行のC列のセルまでを範囲指定します。
'LastRowで一旦行数だけのカウントをします。
For i = 8 To Cells(2, Columns.Count).End(xlToLeft).Column
For j = 3 To Cells(Rows.Count, i).End(xlUp).Row
If Cells(j, i) <> "" Then
'空欄でなければのIF条件です。
With result
'以後、出力結果画面での作業を指定します。
'下の処理は、おそらくfunctionあたりで全部まとめられると思いますが、
'考えるのがめんどうだったので、とりあえず公開。また今度綺麗に書けたらご紹介します。
'というのも、最終行が処理のたびにかわるので、一旦処理を抜けて再度最終行をもとめないと
'一番最後の処理しか反映されないんですよね。。。
LastRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("C" & LastRow).Offset(1, 0) = Cells(3, 3) + " " + Cells(j, i)
.Range("B" & LastRow).Offset(1, 0) = Cells(2, i)
.Range("A" & LastRow).Offset(1, 0) = Cells(3, 2)
LastRow = .Range("C" & Rows.Count).End(xlUp).Row
If Range("B7") = True Then
.Range("C" & LastRow).Offset(1, 0) = "+" + Cells(3, 3) + " " + Cells(j, i)
.Range("B" & LastRow).Offset(1, 0) = Cells(2, i)
.Range("A" & LastRow).Offset(1, 0) = Cells(3, 2)
End If
LastRow = .Range("C" & Rows.Count).End(xlUp).Row
If Range("B9") = True Then
.Range("C" & LastRow).Offset(1, 0) = "[" + Cells(3, 3) + " " + Cells(j, i) + "]"
.Range("B" & LastRow).Offset(1, 0) = Cells(2, i)
.Range("A" & LastRow).Offset(1, 0) = Cells(3, 2)
End If
LastRow = .Range("C" & Rows.Count).End(xlUp).Row
If Range("B11") = True Then
.Range("C" & LastRow).Offset(1, 0) = Chr(34) + Cells(3, 3) + " " + Cells(j, i) + Chr(34)
.Range("B" & LastRow).Offset(1, 0) = Cells(2, i)
.Range("A" & LastRow).Offset(1, 0) = Cells(3, 2)
End If
LastRow = .Range("C" & Rows.Count).End(xlUp).Row
If Range("B13") = True Then
.Range("C" & LastRow).Offset(1, 0) = Cells(j, i) + " " + Cells(3, 3)
.Range("B" & LastRow).Offset(1, 0) = Cells(2, i)
.Range("A" & LastRow).Offset(1, 0) = Cells(3, 2)
End If
LastRow = .Range("C" & Rows.Count).End(xlUp).Row
If Range("B15") = True Then
.Range("C" & LastRow).Offset(1, 0) = "[" + Cells(j, i) + " " + Cells(3, 3) + "]"
.Range("B" & LastRow).Offset(1, 0) = Cells(2, i)
.Range("A" & LastRow).Offset(1, 0) = Cells(3, 2)
End If
LastRow = .Range("C" & Rows.Count).End(xlUp).Row
If Range("B17") = True Then
.Range("C" & LastRow).Offset(1, 0) = Chr(34) + Cells(j, i) + " " + Cells(3, 3) + Chr(34)
.Range("B" & LastRow).Offset(1, 0) = Cells(2, i)
.Range("A" & LastRow).Offset(1, 0) = Cells(3, 2)
End If
End With
End If
Next j
Next i
Application.ScreenUpdating = True
result.Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range(Range("A3"), Range("C" & LastRow)).Select
Selection.Copy
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("E" & LastRow).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End Sub
Sub 記録の削除()
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range(Range("E3"), Range("G" & LastRow)).Clear
End Sub
Sub 記録のコピー()
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range(Range("E3"), Range("G" & LastRow)).Copy
End Sub
Sub 掛け合わせの削除()
Dim rc As Integer
rc = MsgBox("広告グループと掛け合わせワードを削除します。よろしいですか？" & vbCrLf & "※マクロでの削除は取り消しができません。", vbYesNo + vbQuestion, "確認")
'& vbCrLf &をつけることで、コメントの改行ができます。
'vb○○でMsgbox関連のメソッドが登録できます。
If rc = vbYes Then
Range(Range("H2"), Range("H2").SpecialCells(xlCellTypeLastCell)).ClearContents
End If
End Sub
今後の改善点としては、
①指名系キーワードの作成に対応できない。
掛け合わせ前提で作っておりますので、指名系（単キーワード）の出力をしようとすると
エラーになります。
②複数のメインキーワードがある場合、入力に手間がかかる
現状は一個しか対応しておりませんので、複数同時に入力したい場合は、処理ごとにいちいち
メインキーワードの欄に入力しなおさなければなりません。
ver0.1としてすでに会社のパソコンに送り込んでしまっておりますので、
会社で修正するかここで修正するかですが、まぁMacでやったほうが作業が楽なんですよね苦笑
今から茂原にいってきます。
では。
Comments