Webから入手した書誌データを出版社毎に区分けして、出版社名別にシートを新規作成した上で、返品データを振り分けていきます。
重複なしデータ作成などのVBAを組み立てます。
こんにちは、じゅんぱ店長（@junpa33）です。
今回は,返品了解書作成ソフト作りの中で、
Webから入手した「抽出データ」シートに転記されている書誌データを、重複なしで整理整頓して、出版社名毎のシートに仕分けされるプログラムを作成します。
抽出した書誌データを返品了解書のテンプレートへ転記するための準備作業の前半部分になります。
先回の返品了解書作成記事はこちら↓からお読みいただけます。
Webの書誌情報を利用して返品了解書を作成する
コンテンツ
返品了解書の今回作成する作業工程
先回の記事では、「書誌データ貼付」シートを作成し、Webからの書誌情報を利用するVBAを作成しました。
そして、その結果を「抽出データ」シートに送りました。
今回はその送られた書誌データを出版社毎に仕分けする作業を行います。
- 「出版社リスト」シートに返品了解を依頼する出版社名を取り出します。
- その依頼する出版社毎に出版社名のＳｈｅｅｔを新しく作成します。
- 出版社名のシートにそれぞれの返品書誌データを仕分けしていきます。
「抽出データ」から「出版社名シート」までのVBA
この作業用に新たな標準モジュールを挿入追加します。
（挿入の方法はこちら↓で確認できます。）
「ＶＢＥ（ビジュアルベーシックエディター）を起動する」
参考記事
VBA初めての起動。VBEの立ち上げ、保存と終了
「出版社リスト」シートへ出版社名を記述します
「抽出データ」シートに取り出した書誌データは、Webからの書誌情報の取り入れた順番通りにリスト化されています。
出版社くくりにまとめようとした時には、同じ出版社で何冊かあったりと、重複した出版社名を整理する必要があります。
「出版社」シートには、重複しない出版社名がデータとしてリストアップされている必要があります。
そのリストアップにはVBAで”Dictionaryオブジェクト”を使って重複チェックを行うのが簡潔です。
エクセルVBA 同じ項目をまとめる（重複データの整理）コード作成
Dictionaryオブジェクトを使う準備作業として「参照設定」からランタイムの参照が出来るようにします。
＜参照設定で「Microsoft Scripting Runtime」を導入＞
「ツール」から「参照設定…」をクリックします。
「参照設定ーVBAProject」ウインドウで、「Microsoft Scripting Runtime」を選択し「ＯＫ」をクリックしてください。
優先順位「上矢印」を繰って上位に上げておきましょう。
プロシージャー名は「出版社名リストアップ」としてください。
Sub 出版社名リストアップ()
・・・・
End Sub
「Dictionaryオブジェクト」を宣言します。
「Dictionaryオブジェクト」・・・・・myDic
「出版社名」・・・・・SyuN
コード化するとこのようになります。
'変数宣言
Dim s As Long
Dim t As Long
Dim tyuRow As Long
Dim SyuN As Variant
Dim myDic As Dictionary
Set myDic = New Dictionary
重複チェックをしながら出版社名データを送るコードは
このようになります。
データ入力済セルの最終行番号を取得する
エクセルVBA！For～Nextのループと入れ子構造をVBA最速理解
'出版社名を送る
Worksheets("抽出データ").Select
Aho = Worksheets("抽出データ").Range("C2").Value
tyuRow = Cells(Rows.Count, 2).End(xlUp).Row
For s = 1 To tyuRow
SyuN = Cells(s, 3).Value
If myDic.Exists(SyuN) = False Then
myDic.Add SyuN, ""
End If
Next s
Worksheets("出版社リスト").Select
For t = 1 To myDic.Count - 1
Cells(t, 1).Value = myDic.Keys(t)
Next t
出版社別に新しく出版社名シートを作成します
新たにプロシージャー名を「出版社シート」として追加します。
新規作成ブックとシート。アクティブ状態でやっておくこと
Sub 出版社シート()
Dim SyuRow As Long
Dim SN As Variant
Dim t As Long
Worksheets("出版社リスト").Select
SyuRow = Cells(Rows.Count, 1).End(xlUp).Row
For t = 1 To SyuRow
SN = Range("A" & t).Value
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = SN
Worksheets("出版社リスト").Select
Next t
End Sub
シート名を付ける場合、
先に、必要な数のシートを作ってから後で一つづつ名前付けをするよりも
新たなシートを作るときに、同時に名前を付けて行くというのが一番簡単な方法になります。
出版社名シートに書誌データを振り分けます
「出版社リスト」から一つづつ出版社名を拾って「抽出リスト」から該当データを抜き取り、
それぞれの「出版社シート」に転記していきます。
プロシージャー名を「出版社振り分け」として追加します。
Columnsプロパティの列指定で参照する
Sub 出版社振り分け()
Dim SyuRow, tyuRow As Long
Dim SN As Variant
Dim s As Long
Dim t As Long
Dim n As Long
Worksheets("出版社リスト").Select
SyuRow = Cells(Rows.Count, 1).End(xlUp).Row
For t = 1 To SyuRow
SN = Range("A" & t).Value
Worksheets("抽出データ").Select
tyuRow = Cells(Rows.Count, 3).End(xlUp).Row
s = 1
For n = 1 To tyuRow
If Range("C" & n).Value = SN Then
Rows(n).Copy Destination:=Worksheets(SN).Range("A" & s)
s = s + 1
Worksheets(SN).Columns("A:G").AutoFit
End If
Worksheets("抽出データ").Select
Next n
Worksheets("出版社リスト").Select
Next t
End Sub「返品書誌データ整理」ボタンの設置
「操作ボタン」シートに「返品書誌データ整理」プロシージャーを起動するボタンを設置します。
「返品書誌データ整理」ボタンはここまで作成したVBAプログラムを順に実行するためのボタンです。
エラー処理として、対策のためのコードを埋め込みます。
「抽出データ」が空の時（返品書誌データが抽出されていないとき）はプロシージャーを終了します。
今までに作成したプロシージャーを連続で順番に起動するためのプロシージャーとして、
「返品書誌データ整理」プロシージャーを作成します。
部品化プロシージャーでCallステートメントは必須
コマンドボタンをシートに設置する２つの方法
ボタンの設置方法についてはこちらでも↓確認できます。
Sub 返品書誌データ整理()
Worksheets("抽出データ").Select
R = Cells(Rows.Count, 2).End(xlUp).Row
If R <= 1 Then
MsgBox "返品データが取り出されていません！"
Worksheets("操作ボタン").Select
Range("A1").Select
Exit Sub
End If
Call Module2.出版社名リストアップ
Call Module2.出版社シート
Call Module2.出版社振り分け
End Sub
「操作ボタン」シートでの「返品書誌データ整理」ボタンの設置場所は特に指定はありません。
今回作成したＶＢＡコード
Option Explicit
Sub 返品書誌データ整理()
Dim R As Long
Worksheets("抽出データ").Select
R = Cells(Rows.Count, 2).End(xlUp).Row
If R <= 1 Then
MsgBox "返品データが取り出されていません！"
Worksheets("操作ボタン").Select
Range("A1").Select
Exit Sub
End If
Call Module2.出版社名リストアップ
Call Module2.出版社シート
Call Module2.出版社振り分け
End Sub
Sub 出版社名リストアップ()
'変数宣言
Dim s As Long
Dim t As Long
Dim Aho As Variant
Dim tyuRow As Long
Dim SyuN As Variant
Dim myDic As Dictionary
Set myDic = New Dictionary
'出版社名を送る
Worksheets("抽出データ").Select
Aho = Worksheets("抽出データ").Range("C2").Value
tyuRow = Cells(Rows.Count, 2).End(xlUp).Row
For s = 1 To tyuRow
SyuN = Cells(s, 3).Value
If myDic.Exists(SyuN) = False Then
myDic.Add SyuN, ""
End If
Next s
Worksheets("出版社リスト").Select
For t = 1 To myDic.Count - 1
Cells(t, 1).Value = myDic.Keys(t)
Next t
End Sub
Sub 出版社シート()
Dim SyuRow As Long
Dim SN As Variant
Dim t As Long
Worksheets("出版社リスト").Select
SyuRow = Cells(Rows.Count, 1).End(xlUp).Row
For t = 1 To SyuRow
SN = Range("A" & t).Value
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = SN
Worksheets("出版社リスト").Select
Next t
End Sub
Sub 出版社振り分け()
Dim SyuRow, tyuRow As Long
Dim SN As Variant
Dim s As Long
Dim t As Long
Dim n As Long
Worksheets("出版社リスト").Select
SyuRow = Cells(Rows.Count, 1).End(xlUp).Row
For t = 1 To SyuRow
SN = Range("A" & t).Value
Worksheets("抽出データ").Select
tyuRow = Cells(Rows.Count, 3).End(xlUp).Row
s = 1
For n = 1 To tyuRow
If Range("C" & n).Value = SN Then
Rows(n).Copy Destination:=Worksheets(SN).Range("A" & s)
s = s + 1
Worksheets(SN).Columns("A:G").AutoFit
End If
Worksheets("抽出データ").Select
Next n
Worksheets("出版社リスト").Select
Next t
End Sub
抽出データシートからの書誌データ整理まとめ
今回は、Webから順不同に入手して「抽出データ」シートに転記された書誌データが、重複なしで整理整頓して、
出版社名毎のシートに仕分けされるところまで行いました。
次回は、新規に設置するエクセルBOOK「返品了解申請.xlsm」へデータを転送するVBAの作成となります。
電子書籍版「改訂新版 てっとり早く確実にマスターできるＥｘｃｅｌ ＶＢＡの教科書」をamazonで見てみる
（著者）大村あつし（出版社）技術評論社
（税込価格）2,508円（本体2,280円＋税）
30冊を超えるExcelのマクロやVBAの解説書を執筆してきた著者による考え抜かれた本書の内容と構成。
独創的な解説手法で必ずExcel VBAが理解できます！
初級からの参考書ですが、より実践的切り口での解説をしています。
QRコードから操作の流れを動画（無音です）で確認することもできるようになりました。
文章解説と動画との関係性は、主は文章での解説、サポートが動画になります。
次の記事を読むのはこちら↓から
データのあるブックから別のエクセルに値を転送するVBA
エクセルVBAを独習するのに参考書は欠かせません。 参考書選びは自分に合った「相棒」にできるものを選んでいきたいです。
エクセルVBAの独習でおすすめ参考書を7冊選ぶ。良書との出会いは大切です
今回の記事はここまでです。 最後までご覧いただき有難うございました。