Excel2000：既存一覧のデータを任意に配列しなおす

質問

＜現一覧＞(Sheet1)
　　　A　　　　　　B　　C　　D　　　　E　　　F
1　部門CD　 部門　ID　内容　カテゴリ　分類
2　130　　　　経理　 1　　あ　　　ア　　　　a
3　130　　　　経理　 2　　い　　　イ　　　　b
4　130　　　　経理　 3　　う　　　ア　　　　a
5　110　　　　総務　 4　　え　　　ウ　　　　a
6　110　　　　総務　 5　　お　　　イ　　　　d
7　550　　　　営業　 6　　か　　　ウ　　　　c
8　550　　　　営業　 7　　き　　　オ　　　　c
9　550　　　　営業　 8　　く　　　 オ　　　　c

現在、上記の一覧があります。
これを、以下のそれぞれ二つの一覧に、内容の配列を変えて作成出来るでしょうか。

------------------------------------------
一覧(1)
・複数ある同じ「部門」と「部門CD」をまとめる
・「部門CD」と「カテゴリ」をキーにし、「内容」を1セル上にまとめて配列する。

(Sheet2)
　　　A　　 　　B　　 C　 D　 E　 F　G
1　部門CD　部門　ア　イ　ウ　エ　オ
2 　130　　　経理　 あ　い
　　　　　　　　　　　　う
3 　110　　　総務　　　　　え
　　　　　　　　　　　　お
4 　550　　　営業　　　　　 か　 　　き
　　　　　　　　　　　　　　　　　　　　 く
------------------------------------------
一覧(2)
・複数ある同じ「分類」をまとめる
・「分類」と「カテゴリ」をキーにし、該当する「内容」を1セル上にまとめて配列する。

(Sheet3)
　　　A　　B　 C　D　 E　 F
1　分類　ア　イ　ウ　エ　オ
2 　a　 　 あ　　　え
　　　　　　う
3 　b　　　　　い
4 　c　　　　　 　 か　　　き
　　　　　 　 　　　　　　　 く
5　 d　　　　　お
------------------------------------------

こんなこと、なるべくなら関数で出来ますでしょうか。

回答No.3

at121 · ベストアンサー

データ　指定の物
　　　部門CD　は　2文字以上　その他は　1文字以上　が有効　

操作　データシートをアクテブにしてマクロ起動
結果　一覧1のシート（部門CDvsカテゴリ）に
　　　一覧2のシート（分類vsカテゴリ）に
　　　それぞれ　内容を出力

　「内容」を1セル上にまとめて配列　　は　ALT　改行　相当　chr(10)　　区切りは何にでも・・

↓ツール　マクロ　VBエディタ　挿入モジュールに貼り付け↓

Sub 一覧1と一覧2をシート1と2に出力()
'一覧（1）
'部門CDvsカテゴリ⇒内容配置
Set 今のシート = ActiveSheet
Sheets.Add before:=Sheets(1)
Sheets(1).Name = "部門CDvsカテゴリ"
今のシート.Activate

Call 部門CDと部門設定
Call カテゴリ設定(3)
Call 内容分類(1, 5)

'一覧（2）
'分類vsカテゴリ⇒内容配置

Set 今のシート = ActiveSheet
Sheets.Add before:=Sheets(1)
Sheets(1).Name = "分類vsカテゴリ"
今のシート.Activate

Call 分類設定
Call カテゴリ設定(2)
Call 内容分類(6, 5)

End Sub

Sub 部門CDと部門設定()
'「部門CD」A列1 と「部門」B列　を シート１ の見出し A列 に設定
For Each 部門CD In Range(Cells(1, 1), Cells(65536, 1).End(xlUp))
If 1 < Len(部門CD) Then
If Sheets(1).Range("a:a").Find(部門CD) Is Nothing Then
設定行 = 設定行 + 1
Sheets(1).Cells(設定行, 1) = 部門CD.Value
Sheets(1).Cells(設定行, 2) = 部門CD.Offset(0, 1).Value
End If
End If
Next
End Sub

Sub 分類設定()
'「分類」F列6 を シート１ の見出し A列 に設定
For Each 分類 In Range(Cells(1, 6), Cells(65536, 6).End(xlUp))
If 0 < Len(分類) Then
If Sheets(1).Range("a:a").Find(分類) Is Nothing Then
設定行 = 設定行 + 1
Sheets(1).Cells(設定行, 1) = 分類.Value
End If
End If
Next
End Sub

Sub カテゴリ設定(列位置)
'「カテゴリ」E列5 を シート１ の見出し 1行 列位置から右に設定
For Each カテゴリ In Range(Cells(2, 5), Cells(65536, 5).End(xlUp))
If 0 < Len(カテゴリ) Then
If Sheets(1).Range("1:1").Find(カテゴリ) Is Nothing Then
Sheets(1).Cells(1, 列位置) = カテゴリ.Value
列位置 = 列位置 + 1
End If
End If
Next
End Sub

Sub 内容分類(参照縦, 参照横)
'「内容」D列4　の 参照縦　列, 参照横　列より
' シート１ の見出し A列 　　　1行　適合する　セルに　内容を配置
'　参照縦：分類　F列=6　　または　部門CD　A列=1
'　参照横：カテゴリ　E列=5
For Each 内容 In Range(Cells(2, 4), Cells(65536, 4).End(xlUp))
If 0 < Len(Trim(内容)) Then
列A参照 = Cells(内容.Row, 参照縦)
行1参照 = Cells(内容.Row, 参照横)
If Not Sheets(1).Range("a:a").Find(列A参照) Is Nothing Then
If Not Sheets(1).Range("1:1").Find(行1参照) Is Nothing Then
列A⇒行 = Sheets(1).Range("a:a").Find(列A参照).Row
行1⇒列 = Sheets(1).Range("1:1").Find(行1参照).Column
設定内容 = Sheets(1).Cells(列A⇒行, 行1⇒列) & Chr(10) & Trim(内容)
If Left(設定内容, 1) = Chr(10) Then 設定内容 = Mid(設定内容, 2)
Sheets(1).Cells(列A⇒行, 行1⇒列) = 設定内容
End If
End If
End If
Next
End Sub

お礼

at121さん、回答ありがとございます。

素晴らしい！
ちゃんと出来ましたよ～(>_<)
VBEに記述して、多少シート名を変えるくらいで、すぐ出来ました。
まさか、ホントに出来るとは・・・
(質問しておいて、ナンですが)

このようなVBAはいったいどうやってお勉強したらいいんでしょうか。
ホントに素晴らしいです。
どうもありがとうございました。