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はいったいどうやってお勉強したらいいんでしょうか。
ホントに素晴らしいです。
どうもありがとうございました。

回答No.5

moon_piyo

1つのセルにいれるのはわかりませんでした。似たようなものなら

一覧(1)の場合
各セルに式をいれていってください

X1: ア
Y1: イ
Z1: ウ
AA1: エ
AB1: オ

H2: =IF(COUNTIF(A$2:A2,A2)=1,ROW(),SUMPRODUCT((A$1:A1=A2)*INT(H$1:H1))/SUMPRODUCT((A$1:A1=A2)*1)+ROW()/100000)
I2: =RANK(H2,$H$2:$H$9,1)

K2: =INDEX(A$2:A$9,MATCH(ROW()-1,$I$2:$I$9,0))
L2: =INDEX(E$2:E$9,MATCH(ROW()-1,$I$2:$I$9,0))
M2: =INDEX(D$2:D$9,MATCH(ROW()-1,$I$2:$I$9,0))
N2: =INDEX(B$2:B$9,MATCH(ROW()-1,$I$2:$I$9,0))

P2: =SUMPRODUCT((K$2:K2=K2)*(L$2:L2=L2))
Q2: =IF(K2=K1,MAX(P2,Q1),1)
R2: =IF(K2=K1,R1,Q1+R1)
S2: =K1=K2
T2: =ROW()

V2: =IF(SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($S$2:$S$9=FALSE))=0,"",INDEX($K$1:$K$9,SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($S$2:$S$9=FALSE))))
W2: =IF(SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($S$2:$S$9=FALSE))=0,"",INDEX($N$1:$N$9,SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($S$2:$S$9=FALSE))))
X2: =IF(SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=X$1))=0,"",INDEX($M$1:$M$9,SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=X$1))))
Y2: =IF(SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=Y$1))=0,"",INDEX($M$1:$M$9,SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=Y$1))))
Z2: =IF(SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=Z$1))=0,"",INDEX($M$1:$M$9,SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=Z$1))))
AA2: =IF(SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=AA$1))=0,"",INDEX($M$1:$M$9,SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=AA$1))))
AB2: =IF(SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=AB$1))=0,"",INDEX($M$1:$M$9,SUMPRODUCT($T$2:$T$9*($P$2:$P$9+$R$2:$R$9=ROW()-1)*($L$2:$L$9=AB$1))))

H2:AB2を(9列めまで)下方向にコピー
V1:AB9が結果です

一覧(2)の場合
一覧(1)とほとんど同じです
H2とK2を代入する式を変えてください。あとW列は消してください
H2: =IF(COUNTIF(F$2:F2,F2)=1,ROW(),SUMPRODUCT((F$1:F1=F2)*INT(H$1:H1))/SUMPRODUCT((F$1:F1=F2)*1)+ROW()/100000)
K2: =INDEX(F$2:F$9,MATCH(ROW()-1,$I$2:$I$9,0))

お礼

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

似たようなことでも、関数で出来るんですね。
(私はホントに素人なので・・・)

一覧じたいは、#3さんのVBAで作成出来ましたが、関数でも出来ると、VBAよりはまだ分かる私としては嬉しいかぎりです。
お勉強のためにも、時間のある時に検証してみますね。

どうもありがとうございました。

回答No.4

fukkyse

似たようなものなら…。一覧（1）の場合

A1～F9のピボットテーブルを作成。
行のフィールドに、「部門CD」と「内容」
列のフィールドに、「カテゴリー」
データアイテムに、「内容」（データの個数でよいでしょう）

「部門CD」がA5からスタートしているとして、[=IF(ISNUMBER(A5),A5,"")]として「部門CD」を別セルに抽出。
「内容」がB列、「カテゴリー：ア」がC列にあるとして、=IF(ISNUMBER(C5),B5,"")。「カテゴリー：イ」がD列にあるとして、=IF(ISNUMBER(D5),B5,"")。同様にウ～オを作成。

下方向へ、オートフィル。部門についてはVLOOKUPなどで…。かなり似たようなものができると思うのですが。

お礼

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

似たようなことでも、関数で出来るんですね。
(私はホントに素人なので・・・)

一覧じたいは、下の方のVBAで作成出来ましたが、関数でも出来ると、VBAよりはまだ分かる私としては嬉しいかぎりです。
お勉強のためにも、時間のある時に検証してみますね。

どうもありがとうございました。

回答No.2

Wendy02

以前にも、同様の質問を見たことがありますが、提示されたような正規化は、仮に、VBAでも、Excel では不得意です。
例えば、Sheet2 の、「う」や「お」は、なぜ、その行に来るのか、論理的な説明がない限りは、不可能だと思います。

回答No.1

BLUEPIXY

VBAでないと難しいと思います

お礼

BLUEPIXYさん、アドバイスありがとうございます。

そうですか、やはりVBAでないとダメなんですか・・・。

ただもしVBAでも、記述さえ注記付きで書いていただけたら、なんとか判読出来るかな・・・とは思います。

ご存知でしたら、またお付き合い下さい。