指定値でシート内データを分割し単独xlsxファイルへ切出すVBA

##経緯
Excelで全体データから指定値レコードだけを抽出してシート保存、
さらにシートごとにファイルへ保存する作業がクソだるかったのでつくりました。
うまくできたので、空いた時間でTwitterでもしたいと思います。

##ゴール
Sheet1にあるデータを、Sheet2で指定した分だけ、
こんな感じで複数シートに分割します。
![スクリーンショット 2019-08-15 16.12.08.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/45456544-c34c-8f22-4e7c-487aff3e2fa4.jpeg)

また、分割生成したシートは、都度単独のｘｌｓｘファイルとしても保存します。
![スクリーンショット 2019-10-06 17.44.35.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/071993a5-e132-3c3b-29d9-ec673cdaf238.jpeg)

手作業でしてたんです。たるい。

##データの準備
###分割したいデータ
まず、分割元のシート（Sheet1）です。
一番左端に数値で示された団体キーがあり、昇順に並んでます。
例では団体キーの項目名が　0　ですが、あえてです。

自データで試したいときは、「左端列を挿入して、分割したいグループごとに異なる数値を指定」してみてください。
後述のVBAコードをファイル内に保存する必要がなければ、別にxlsmで保存しておかなくても大丈夫です。

```CSV
0,ColumnData1,ColumnData2,ColumnData3,ColumnData4,ColumnData5,ColumnData6,ColumnData7,ColumnData8,ColumnData9
4321,hhhhh-1-1,hhhhh-2-1,hhhhh-3-1,hhhhh-4-1,hhhhh-5-1,hhhhh-6-1,hhhhh-7-1,hhhhh-8-1,hhhhh-9-1
4321,hhhhh-1-2,hhhhh-2-2,hhhhh-3-2,hhhhh-4-2,hhhhh-5-2,hhhhh-6-2,hhhhh-7-2,hhhhh-8-2,hhhhh-9-2
4321,hhhhh-1-3,hhhhh-2-3,hhhhh-3-3,hhhhh-4-3,hhhhh-5-3,hhhhh-6-3,hhhhh-7-3,hhhhh-8-3,hhhhh-9-3
4321,hhhhh-1-4,hhhhh-2-4,hhhhh-3-4,hhhhh-4-4,hhhhh-5-4,hhhhh-6-4,hhhhh-7-4,hhhhh-8-4,hhhhh-9-4
4321,hhhhh-1-5,hhhhh-2-5,hhhhh-3-5,hhhhh-4-5,hhhhh-5-5,hhhhh-6-5,hhhhh-7-5,hhhhh-8-5,hhhhh-9-5
111111,aaaaa-1-1,aaaaa-2-1,aaaaa-3-1,aaaaa-4-1,aaaaa-5-1,aaaaa-6-1,aaaaa-7-1,aaaaa-8-1,aaaaa-9-1
111111,aaaaa-1-2,aaaaa-2-2,aaaaa-3-2,aaaaa-4-2,aaaaa-5-2,aaaaa-6-2,aaaaa-7-2,aaaaa-8-2,aaaaa-9-2
111111,aaaaa-1-3,aaaaa-2-3,aaaaa-3-3,aaaaa-4-3,aaaaa-5-3,aaaaa-6-3,aaaaa-7-3,aaaaa-8-3,aaaaa-9-3
111111,aaaaa-1-4,aaaaa-2-4,aaaaa-3-4,aaaaa-4-4,aaaaa-5-4,aaaaa-6-4,aaaaa-7-4,aaaaa-8-4,aaaaa-9-4
111111,aaaaa-1-5,aaaaa-2-5,aaaaa-3-5,aaaaa-4-5,aaaaa-5-5,aaaaa-6-5,aaaaa-7-5,aaaaa-8-5,aaaaa-9-5
111111,aaaaa-1-6,aaaaa-2-6,aaaaa-3-6,aaaaa-4-6,aaaaa-5-6,aaaaa-6-6,aaaaa-7-6,aaaaa-8-6,aaaaa-9-6
111111,aaaaa-1-7,aaaaa-2-7,aaaaa-3-7,aaaaa-4-7,aaaaa-5-7,aaaaa-6-7,aaaaa-7-7,aaaaa-8-7,aaaaa-9-7
123456,ggggg-1-1,ggggg-2-1,ggggg-3-1,ggggg-4-1,ggggg-5-1,ggggg-6-1,ggggg-7-1,ggggg-8-1,ggggg-9-1
123456,ggggg-1-2,ggggg-2-2,ggggg-3-2,ggggg-4-2,ggggg-5-2,ggggg-6-2,ggggg-7-2,ggggg-8-2,ggggg-9-2
123456,ggggg-1-3,ggggg-2-3,ggggg-3-3,ggggg-4-3,ggggg-5-3,ggggg-6-3,ggggg-7-3,ggggg-8-3,ggggg-9-3
123456,ggggg-1-4,ggggg-2-4,ggggg-3-4,ggggg-4-4,ggggg-5-4,ggggg-6-4,ggggg-7-4,ggggg-8-4,ggggg-9-4
123456,ggggg-1-5,ggggg-2-5,ggggg-3-5,ggggg-4-5,ggggg-5-5,ggggg-6-5,ggggg-7-5,ggggg-8-5,ggggg-9-5
222222,bbbbb-1-1,bbbbb-2-1,bbbbb-3-1,bbbbb-4-1,bbbbb-5-1,bbbbb-6-1,bbbbb-7-1,bbbbb-8-1,bbbbb-9-1
222222,bbbbb-1-2,bbbbb-2-2,bbbbb-3-2,bbbbb-4-2,bbbbb-5-2,bbbbb-6-2,bbbbb-7-2,bbbbb-8-2,bbbbb-9-2
222222,bbbbb-1-3,bbbbb-2-3,bbbbb-3-3,bbbbb-4-3,bbbbb-5-3,bbbbb-6-3,bbbbb-7-3,bbbbb-8-3,bbbbb-9-3
333333,ccccc-1-1,ccccc-2-1,ccccc-3-1,ccccc-4-1,ccccc-5-1,ccccc-6-1,ccccc-7-1,ccccc-8-1,ccccc-9-1
333333,ccccc-1-2,ccccc-2-2,ccccc-3-2,ccccc-4-2,ccccc-5-2,ccccc-6-2,ccccc-7-2,ccccc-8-2,ccccc-9-2
333333,ccccc-1-3,ccccc-2-3,ccccc-3-3,ccccc-4-3,ccccc-5-3,ccccc-6-3,ccccc-7-3,ccccc-8-3,ccccc-9-3
333333,ccccc-1-4,ccccc-2-4,ccccc-3-4,ccccc-4-4,ccccc-5-4,ccccc-6-4,ccccc-7-4,ccccc-8-4,ccccc-9-4
333333,ccccc-1-5,ccccc-2-5,ccccc-3-5,ccccc-4-5,ccccc-5-5,ccccc-6-5,ccccc-7-5,ccccc-8-5,ccccc-9-5
444444,ddddd-1-1,ddddd-2-1,ddddd-3-1,ddddd-4-1,ddddd-5-1,ddddd-6-1,ddddd-7-1,ddddd-8-1,ddddd-9-1
444444,ddddd-1-2,ddddd-2-2,ddddd-3-2,ddddd-4-2,ddddd-5-2,ddddd-6-2,ddddd-7-2,ddddd-8-2,ddddd-9-2
444444,ddddd-1-3,ddddd-2-3,ddddd-3-3,ddddd-4-3,ddddd-5-3,ddddd-6-3,ddddd-7-3,ddddd-8-3,ddddd-9-3
444444,ddddd-1-4,ddddd-2-4,ddddd-3-4,ddddd-4-4,ddddd-5-4,ddddd-6-4,ddddd-7-4,ddddd-8-4,ddddd-9-4
555555,eeeee-1-1,eeeee-2-1,eeeee-3-1,eeeee-4-1,eeeee-5-1,eeeee-6-1,eeeee-7-1,eeeee-8-1,eeeee-9-1
555555,eeeee-1-2,eeeee-2-2,eeeee-3-2,eeeee-4-2,eeeee-5-2,eeeee-6-2,eeeee-7-2,eeeee-8-2,eeeee-9-2
555555,eeeee-1-3,eeeee-2-3,eeeee-3-3,eeeee-4-3,eeeee-5-3,eeeee-6-3,eeeee-7-3,eeeee-8-3,eeeee-9-3
555555,eeeee-1-4,eeeee-2-4,eeeee-3-4,eeeee-4-4,eeeee-5-4,eeeee-6-4,eeeee-7-4,eeeee-8-4,eeeee-9-4
666666,fffff-1-1,fffff-2-1,fffff-3-1,fffff-4-1,fffff-5-1,fffff-6-1,fffff-7-1,fffff-8-1,fffff-9-1
666666,fffff-1-2,fffff-2-2,fffff-3-2,fffff-4-2,fffff-5-2,fffff-6-2,fffff-7-2,fffff-8-2,fffff-9-2
```

実際のシート（Sheet1）はこんな感じ。
左端列に入っている数値のうち、Sheet2で切り出したいグループの数値を指定して、別シートへ切り出します。
![スクリーンショット 2019-08-15 16.23.19.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/983a5c07-71d7-2d7e-cbfd-b88e1be8dbf5.jpeg)

###切り出したい団体を指定
切り出したいグループの数値をSheet2に指定しておきます。
```
CITY
4321
111111
123456
222222
333333
444444
555555
666666
```

実際のシート（Sheet2）のイメージはこんな感じ。
![スクリーンショット 2019-08-15 16.29.33.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/ec92e0d0-0a1a-c6c8-26f0-659ba0498038.jpeg)

一部指定でもおｋ。
![スクリーンショット 2019-08-15 16.28.32.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/25de7b45-31cb-609d-92e3-b6b9032545ab.jpeg)


準備OK．
![スクリーンショット 2019-08-15 16.43.29.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/34348b6b-7427-35eb-4b09-bf23ecbd946f.jpeg)

##VBAの準備
最後にVBA。

```
Option Explicit

Option Explicit

Sub Sheet1をSheet2と突合し分割()
'各マスタの行数・列数を取得
   'CITYマスタの最終行数
   Dim rowsSheet2 As Long
   rowsSheet2 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
   
   'DATAマスタの最終行数
   Dim rowsSheet1 As Long
   rowsSheet1 = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
   'DATAマスタの最終列数
   Dim colsData As Long
   colsData = Sheet1.Cells(1, Columns.Count).End(xlToRight).Column
   '突合ループ内で突合するDATAの範囲(開始位置)行数（初期値）
   Dim searchRangeStart As Long
   'DATAマスタの先頭
   searchRangeStart = "1"
   '突合ループ内で突合するDATAの範囲(終了位置)行数（初期値）
   Dim searchRangeEnd As Long
   'DATAマスタの最終行数
   searchRangeEnd = rowsSheet1

'突合ループ
   '突合ループ用変数宣言
   Dim n As Long
   Dim m As Long
   '突合成功フラグ
   Dim matchFlag As Integer
   matchFlag = 0 '倒しておく
   '突合範囲スタートエンド
   Dim matchRangeStart As Long
   Dim matchRangeEnd As Long
   
   Dim Target As String
   
          
   'CITYのはじめから終わりまで
   For n = 2 To rowsSheet2
           Sheet2.Select
           Dim k As Long
           k = Sheet2.Cells(n, 1).Value
   
       'DATAのCITYごとの範囲で
       For m = 1 To searchRangeEnd
       
           Sheet1.Select
           Dim l As Long
           l = Sheet1.Cells(m, 1).Value
           
           'CITYコードが一致
           If k = l Then
               '突合フラグが立ってなかったら、立てる（突合中CITYコードの最初のヒット）
               If matchFlag = 0 Then
                   matchRangeStart = m
                   matchFlag = 1
               End If
           End If
           
           '突合検索がDATA最終行まで到達
           If m = searchRangeEnd Then
               '直前までに突合していれば、
               If matchFlag = 1 Then
                   '突合範囲を確定
                   matchRangeEnd = m
                   '新規ワークシートを開き、突合選択中のCITY名称を設定、オブジェクト指定する
                   Worksheets.Add
                   ActiveSheet.Name = Sheet2.Cells(n, 1).Value
                   Target = ActiveSheet.Name
                   Dim wsi As Worksheet
                   Set wsi = ActiveSheet
                   '作成したワークシートに突合範囲を行ごとコピーする
                   Sheet1.Range(matchRangeStart & ":" & matchRangeEnd).Copy wsi.Range("A1")
                   'フラグ倒す
                   matchFlag = 0
                   '作成した分割抽出シートを、新規ブックへコピーする
                   ActiveSheet.Copy
                   ActiveWorkbook.SaveAs Target & ".xlsx"
                   ActiveWorkbook.Close
               End If
           End If
           
           'CITYコードが不一致
           If k < l Then
               '直前までに突合していれば、
               If matchFlag = 1 Then
                   '突合範囲を確定（一つ前の行迄）
                   matchRangeEnd = m - 1
                   '新規ワークシートを開き、突合選択中のCITY名称を設定、オブジェクト指定する
                   Worksheets.Add
                   ActiveSheet.Name = Sheet2.Cells(n, 1).Value
                   Target = ActiveSheet.Name
                   Dim wsj As Worksheet
                   Set wsj = ActiveSheet
                   '作成したワークシートに突合範囲を行ごとコピーする
                   Sheet1.Range(matchRangeStart & ":" & matchRangeEnd).Copy wsj.Range("A1")
                   'フラグ倒す
                   matchFlag = 0
                   '作成した分割抽出シートを、新規ブックへコピーする
                   ActiveSheet.Copy
                   ActiveWorkbook.SaveAs Target & ".xlsx"
                   ActiveWorkbook.Close
               End If
               'DATAとの突合ループmを抜ける
               Exit For
           End If
           
       Next m
   Next n
End Sub


```

開発＞VisualBasicエディターから、標準モジュールに保存しておきます。

##実行

そぉい！
![スクリーンショット 2019-08-15 16.45.25.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/10a8973b-df81-a275-bd60-c718aaf8af18.jpeg)

##結果
できました。
![スクリーンショット 2019-08-15 16.12.08.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/18f12db8-a7d7-fc9a-56ce-c22e12ca9118.jpeg)

分割したシートはこんな感じ。
![スクリーンショット 2019-08-15 16.47.32.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/4c35956a-f5ee-e236-41d8-18513b40c40b.jpeg)
![スクリーンショット 2019-08-15 16.47.50.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/db01009c-0329-32b7-a123-269a86f0b0ae.jpeg)
![スクリーンショット 2019-08-15 16.48.15.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/69ff29cb-f02f-5d99-e8a2-ecc309e2e64e.jpeg)


xlsxファイルも生成されています。
![スクリーンショット 2019-10-06 17.44.35.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/cbd10428-3601-5c46-47d5-da11e063ee38.jpeg)


Sheet2で一部指定で実行したとき。
![スクリーンショット 2019-08-15 16.28.17.jpg](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/151818/5a4b76ff-ddcd-69f0-9442-fba983538d40.jpeg)
指定したものだけシート生成されてます。


やり直すときは、生成されたシートを削除して、Sheet1・Sheet2だけの状態に戻してから。


##所感

「全体データのうちの一部を抽出して個別に保存し直して送付」
という作業は割とどこでも発生していると思うんですが、
もうほんとに面倒なのでつくりました。

ここまでできればあとはコピペしたファイル名を送付先毎につけ直すだけの作業なので、
目的は達成できたと思います。