はじめに
元表のなかにあるカテゴリには、開発、デザイン、コンサルティングの項目が重複して入っている。
これをカテゴリの開発、デザイン、コンサルティングの項目別に新規シートを作り、元表のデータを分類する。
3通りのやり方を紹介する。
また、運用に際しては、1度きりしかできず、2回目以降はエラーがでる（すでに項目別のシートができている）ので、二度目以降はプログラムが動かないように工夫しなければならない。（解法３でそれを行っている）
問題
データ
| 案件番号 | 案件名 | カテゴリ | 契約金額 | 受注日 | 担当社員番号 | 担当社員氏名 | ステータス |
| 100192 | RPAツールの開発業務 | 開発 | ######## | 2020/4/5 | 3101 | 高橋 優子 | ①未アサイン |
| 100195 | デザインの相談 | デザイン | 2,146,000 | 2020/4/16 | 3101 | 田中 希美 | ②作業中 |
| 100197 | パッケージデザイン | デザイン | 1,869,000 | 2020/4/25 | 3102 | 佐藤 菜美 | ③完了 |
| 100201 | アプリの新規開発・改修業務 | 開発 | ######## | 2020/5/14 | 2103 | 桐生 奈美 | ③完了 |
| 100202 | サービスのロゴ作成 | デザイン | 1,348,000 | 2020/5/27 | 3108 | 田中 彩子 | ②作業中 |
| 100204 | バナーのデザイン | デザイン | 2,940,000 | 2020/6/19 | 3109 | 渡辺 里奈 | ③完了 |
| 100208 | パンフレットデザイン | デザイン | 1,100,000 | 2020/6/21 | 3114 | 佐藤 衣子 | ②作業中 |
| 100209 | iOS開発業務 | 開発 | ######## | 2020/7/14 | 3115 | 佐藤 茂 | ③完了 |
| 100210 | プロダクト開発業務 | 開発 | ######## | 2020/7/26 | 3117 | 山吹 茂 | ③完了 |
| 100215 | UI・UX改善 | コンサルティング | 1,036,000 | 2020/8/2 | 3114 | 佐藤 心音 | ②作業中 |
| 100216 | データ分析業務 | コンサルティング | 1,172,000 | 2020/8/18 | 3119 | 一条 梨乃 | ①未アサイン |
| 100221 | WEBサイトデザイン | デザイン | 2,604,000 | 2020/9/7 | 3122 | 斎藤 和夫 | ②作業中 |
| 100223 | バックエンド開発 | 開発 | ######## | 2020/9/12 | 3127 | 田中 奈美 | ③完了 |
| 100224 | WEBアプリケーション開発業務 | 開発 | ######## | 2020/10/7 | 3131 | 佐藤 茂 | ③完了 |
| 100226 | 自社サービスの開発 | 開発 | ######## | 2020/11/5 | 3135 | 山吹 茂 | ②作業中 |
| 100234 | アプリの新規開発・改修業務 | 開発 | ######## | 2020/11/6 | 3114 | 佐藤 心音 | ③完了 |
| 100240 | サービスのロゴ作成 | デザイン | 2,482,000 | 2020/11/16 | 3119 | 一条 梨乃 | ②作業中 |
| 100240 | サービス紹介のチラシデザイン | デザイン | 1,855,000 | 2020/11/27 | 3101 | 田中 希美 | ③完了 |
| 100249 | iOS開発業務 | 開発 | ######## | 2020/12/14 | 3102 | 佐藤 菜美 | ③完了 |
| 100253 | デザインの相談 | デザイン | 1,725,000 | 2020/12/18 | 2103 | 桐生 奈美 | ②作業中 |
| 100256 | パッケージデザイン | デザイン | 1,236,000 | 2021/1/14 | 3108 | 田中 彩子 |
③完了 |
| 100262 | サービスのロゴ作成 | デザイン | 2,927,000 | 2021/2/5 | 3109 | 渡辺 里奈 | ③完了 |
契約金額以外はコピーしてエクセルに貼り付けても＃がでることはないので、貼り付ける際には、＃のところの契約金額を自由に書き込むこと。
解法１）項目別にサブルーチンを作成する。
Option Explicit
Option Base 1
ーーーーーーーーーーーーーーーーーーーーーーー
Sub main()
Call dt_split1
Call dt_split2
Call dt_split3
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Sub dt_split1()
Dim sht As Worksheet
With Sheets("Sheet1")
.Range("A1").AutoFilter Field:=3, Criteria1:="開発"
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = "開発"
.Range("A1").CurrentRegion.Copy Sheets("開発").Range("A1")
.Range("A1").AutoFilter
End With
ActiveWorkbook.Save
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Sub dt_split2()
Dim sht As Worksheet
With Sheets("Sheet1")
.Range("A1").AutoFilter Field:=3, Criteria1:="デザイン"
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = "デザイン"
.Range("A1").CurrentRegion.Copy Sheets("デザイン").Range("A1")
.Range("A1").AutoFilter
End With
ActiveWorkbook.Save
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Sub dt_split3()
Dim sht As Worksheet
With Sheets("Sheet1")
.Range("A1").AutoFilter Field:=3, Criteria1:="コンサルティング"
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = "コンサルティング"
.Range("A1").CurrentRegion.Copy Sheets("コンサルティング").Range("A1")
.Range("A1").AutoFilter
End With
ActiveWorkbook.Save
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
これは、処理の流れは全く同じで、ただ項目を変更しているだけである。
AutoFilterを用いて元表のデータを絞り込み、Setステートメントでシートを追加し、名前をつけて、あとは絞り込んだデータを新しいシートにコピーしているだけである。やり方としては最も原始的なやり方である。
また最後のAutoFilterは引数を書いていないが、これでオートフィルタは解除される。
キックするマクロはmain()である。
解法２）配列に直接、項目を代入し、ループする
Option Explicit
Option Base 1
ーーーーーーーーーーーーーーーーーーーーーーー
Sub main()
Dim i As Integer
Dim ctgry(3) As String
Dim sht As Worksheet
ctgry(1) = "開発"
ctgry(2) = "デザイン"
ctgry(3) = "コンサルティング"
For i = 1 To 3
With Sheets("Sheet1")
.Range("A1").AutoFilter Field:=3, Criteria1:=ctgry(i)
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = ctgry(i)
.Range("A1").CurrentRegion.Copy Sheets(ctgry(i)).Range("A1")
.Range("A1").AutoFilter
End With
ActiveWorkbook.Save
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
ループの中身自体は解法１）と変わったところはない。Criteria1とsht.Nameに配列を入れているだけである。
解法３）項目を重複なく取り出す
Option Explicit
Option Base 1
ーーーーーーーーーーーーーーーーーーーーーーー
Sub main()
Dim i As Integer
Dim sht As Worksheet
Dim mydata As New Collection
With Sheets("Sheet1")
On Error Resume Next
For i = 2 To Cells(Rows.Count, 3).End(xlUp).Row
mydata.Add Cells(i, 3), Cells(i, 3)
Next i
End With
On Error Goto 0
If Sheets.Count > mydata.Count Then Exit Sub
For i = 1 To mydata.Count
With Sheets("Sheet1")
.Range("A1").AutoFilter Field:=3, Criteria1:=mydata(i)
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = mydata(i)
.Range("A1").CurrentRegion.Copy Sheets(sht.Name).Range("A1")
.Range("A1").AutoFilter
End With
ActiveWorkbook.Save
Next i
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
重複したものは受け付けない という、Collectionの性質を使って、コードによって重複のない項目を取り出している。
On Error Resume Next というのは重複した項目を取ろうとする場合、エラーがでてプログラムが止まってしまうのを避けるために記述するコードである。
On Error Goto 0 というのは、エラーを回避するコード（On Error Resume Next）を解除するためのコードである。
この2つはセットで使わなければならない。
If Sheets.Count > mydata.Count Then Exit Sub これが2回目以降、プログラムを走らせないコードである。簡単にいえば、シートの枚数が項目よりも多くなればプログラムを脱出しますよ、ということである。
このコード以降は、解法２）で行った配列と同じである。
サイトご利用方法
次のページ・前のページを利用するよりも、グローバルメニュー（ヘッダー部分にある項目）・サブメニュー記事の項目をクリックしていただければ、その項目の全体像が一目でみることができ、クリックすればそのサイトへ飛びます。
google、yahoo、Bingなどで検索する場合、検索ワードは先頭に、孤立じじい、と入力しその後に、グローバルメニュー・サブメニュー記事のどれかひとつの項目を入力すると、その検索サイトが上位表示されます。