Excel 同じ組の名前を集めたい

質問

Excel2003です
　組番号を行1に名前を行2に書いた名簿があります。
　（組は、数値で入力　表示形式で組を表示している）

　　A　　 B 　 C D E F G H
1　 組　 1組　2組　　1組　 3組　1組　 2組　 3組
2　名前　東京　大阪　名護　八田　宮下　大木　津軽

この名簿の名前を別シートに次のように組ごとに集めたい
　　A　　 B 　 C 　　D
1　1組　東京　名護　宮下
2　2組　大阪 大木
3　3組 八田　津軽

よろしくお願いします。

画像を参照してください。

回答No.2

merlionXX · ベストアンサー

関数では考えるだけでかなり面倒くさそうですね。
もし表の配置がお書きになったようにA1から始まり、１行目が組、A列が名前の連続したデータなら、以下の手順（VBA）をおためしください。

1.AltキーとF11キー同時に押し（以下Alt+F11キーと記述）て Visual Basic Editor を呼び出します。

2.Visual Basic Editor のメニューから「挿入」、「標準モジュール」で、出てきたコードウィンド（右側の白い広い部分）に以下のコード（Sub～End Sub）をコピペします。

'********これより下**********

Sub test01()
Dim x As Long, i As Long, myStr As String
Dim vK, vI
Dim myDic As Object, ns As Worksheet
With Range("A1").CurrentRegion.Rows 'A1の連続範囲
x = .Columns.Count '列数取得
vK = .Item(1).Value '1行目データ
vI = .Item(2).Value '2行目データ
End With
Set myDic = CreateObject("Scripting.Dictionary")
For i = 2 To x '2列目から最終列まで
myStr = vK(1, i) '1行目データ
If Not myDic.Exists(myStr) Then 'myDicになければ
myDic.Add Key:=myStr, Item:=vI(1, i) '追加
Else 'あれば、2行目データを追加
myDic(myStr) = myDic(myStr) & "＾" & vI(1, i)
End If
Next i
Set ns = Worksheets.Add(After:=ActiveSheet) 'シートを追加
With ns '転記して分離
.Cells(1, 1).Resize(myDic.Count).Value = Application.Transpose(myDic.Keys) '
.Cells(1, 2).Resize(myDic.Count).Value = Application.Transpose(myDic.Items)
.Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, Other:=True, OtherChar:="＾" '
End With
End Sub

'********これより上**********

3.Alt+F11キーでワークシートへもどります.

4.Alt+F8キーで出てきたマクロ名（test01）を選択して実行します。
これで、新しいシートが挿入されて、そこにご要望のように表示されるはずです。

お礼

回答ありがとうございます。
齢70弱の老爺には、横文字（敵国語）の羅列を見るだけで頭痛です。
せっかくお答えいただいたのに申し訳ありません。
VBAやマクロは、ノーサンキュウー（敵国語だ！）と書くべきでした

回答No.5

Wendy02

こんにちは。

>齢70弱の老爺には、横文字（敵国語）の羅列を見るだけで頭痛です。

ちょっと脱線させてください。読んでいただきたいことがあります。

「敵国語」というのは冗談ですよね。そのようなことを言う年代ではないと思います。ここのサイトの回答者さんたちは、意外に年齢が高いそうです。70代だからといわれても、驚きはしませんし、斟酌しようとも思わないです。ここに書いている人たちが、みな若い人たちだと思わないでください。どうみても、書いている時間帯からしても、文章からしても、若くないなって思う人もいます。

ここで書いている回答者でも、マクロのコードで、懐かしい、BASICコードを書く人がいます。それでも、間違いではありません。マクロを書けとは言いませんが、せめて、多少でも、試してみる必要はあると思います。

ご質問者さんは、たぶん、Microsoft 製品は、40代ごろの登場で、Windows の登場が、50代半ばでしょうから、覚えられなかったわけではなくて、そういう選択をしなかっただけだと思います。でも、Excelは使えるわけですよね。ただ、あっという間の20年だったと思います。

私自身、Excel自体を覚えたのは、遅いスタートですが、それでも、一通りは、人に教えても恥ずかしくないくらいは覚えたつもりです。

しかし、私の年代では、もう次世代型コンピュータを操る日は来ないとは思いますし、それ以上に、次・次バージョンのOffice は、おそらく扱えないかもしれないかもしれないという気持ちはあるのですが、やれるところまでやるしかありません。もちろん、Microsoft Office が続くかどうかも、非常に難しい岐路には立っています。

私は、今のところは、何とか、自分の技術はキープはしているものの、このコンピュータの世界は、新しい技術が出てくれば一変に替わってしまいます。以前、一度は、まったく手が付けられない世界になってしまったものの、また追いつきました。

この先も、新しいものは拒否しないように、挑戦し続けたほうが良いと思います。

お礼

ご指摘ごもっともです。
敵国語とは、英語ができないというコンプレックスからです。

ボケ防止のため、パソコンをリタイア後独学で勉強していますがマクロやVBAまで手を伸ばす元気がありません。
関数で対処できれば関数でと考えています。
今後ともご指導よろしくお願いします。

回答No.4

Wendy02

こんばんは。

シート2のA1 に、「1組」と入れて、オートフィルコピーで下に必要なだけ出します。
（１組の「1」の半角・全角の間違いには気をつけてください）

B1 に以下の式を入れます。範囲は適当に変えてください。ただ、COLUMNは、必ず、初期値は、A1になります。

=IF(COLUMN(A1)>COUNTIF(Sheet1!$B$1:$H$1,$A1),"",INDEX(Sheet1!$B$1:$H$2,2,SMALL(INDEX(($A1=Sheet1!$B$1:$H$1)*COLUMN($B$1:$H$1),,),COLUMN(A1)+COUNTIF(Sheet1!$B$1:$H$1,"<>"&$A1))-1))

これをオートフィルコピーで横に、また下に必要なだけ広げます。

上記の式をマクロになるべく近い感じに、マクロらしさを失わないようにして移植してみました。うまく移植できているか自身がありませんので、エラートラップを置いています。

標準モジュールに張りつけます。
'--------------------------------------------------------
Sub Test1()
　　Const START As String = "B1"
　　Dim v1 As Variant
　　Dim v2 As Variant
　　Dim ar As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim n() As String
　　Dim m() As String
　　Dim ret As Variant
　　On Error GoTo ErrHandler
　　With Worksheets("Sheet1")
　　　　v1 = Application.Index(.Range(START, Range("IV1").End(xlToLeft)).Value, 1, 0)
　　　　v2 = Application.Index(.Range(START, Range("IV1").End(xlToLeft)).Offset(1).Value, 1, 0)
　　　　j = UBound(v1)
　　　　ReDim n(j)
　　　　ReDim m(j)
　　　　For i = 1 To j
　　　　　　ret = Application.Match(v1(i), n, 0)
　　　　　　If IsError(ret) Then
　　　　　　　　n(k) = v1(i)
　　　　　　　　m(k) = v2(i)
　　　　　　　　k = k + 1
　　　　　　Else
　　　　　　　　m(ret - 1) = m(ret - 1) & "," & v2(i)
　　　　　　End If
　　　　Next i
　　End With
　　ret = Application.Match("", n, 0)
　　ReDim Preserve n(ret - 2)
　　ret = Application.Match("", m, 0)
　　ReDim Preserve m(ret - 2)
　　With Worksheets("Sheet2") 'Sheet2へ移す
　　　　.Cells(1, 1).Resize(UBound(n) + 1).Value = Application.Transpose(n)
　　　　For i = LBound(m) To UBound(m)
　　　　　　If m(i) <> "" Then
　　　　　　　　ar = Split(m(i), ",")
　　　　　　　　.Cells(i + 1, 2).Resize(, UBound(ar) + 1).Value = ar
　　　　　　End If
　　　　Next i
　　End With
　　Exit Sub
ErrHandler:
　MsgBox Err.Number & " ; " & Err.Description
End Sub

'--------------------------------------------------------

お礼

回答ありがとうございます。

マクロは見ただけで頭痛がしますが
関数でうまくいきました
これから内容を分析したいと思います。

取り急ぎ御礼します。

回答No.3

merlionXX

No2です。
先ほどのでは、Sheet1がアクティブになっていない（選択されていない）状態で実行すれば失敗します。
また、データの転記先はSheet2に決まっているのですね？見落としていました。Sheet2に転記するよう修正しました。

Sub test01()
Dim x As Long, i As Long, myStr As String
Dim vK, vI
Dim myDic As Object
With Sheets("Sheet1").Range("A1").CurrentRegion.Rows 'Sheet1,A1の連続範囲
x = .Columns.Count '列数取得
vK = .Item(1).Value '1行目データ
vI = .Item(2).Value '2行目データ
End With
Set myDic = CreateObject("Scripting.Dictionary")
For i = 2 To x '2列目から最終列まで
myStr = vK(1, i) '1行目データ
If Not myDic.Exists(myStr) Then 'myDicになければ
myDic.Add Key:=myStr, Item:=vI(1, i) '追加
Else 'あれば、2行目データを追加
myDic(myStr) = myDic(myStr) & "＾" & vI(1, i)
End If
Next i
With Sheets("Sheet2") '転記して分離
.Cells(1, 1).Resize(myDic.Count).Value = Application.Transpose(myDic.Keys) '
.Cells(1, 2).Resize(myDic.Count).Value = Application.Transpose(myDic.Items)
.Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, Other:=True, OtherChar:="＾" '
End With
End Sub

回答No.1

gooid1950

■まず行と列を入れ替えて組毎にまとまるように並びければ結果としてはいいのではないでしょうか。
■最初に入力してある範囲を選択してコピーします、次に他のワークシ-トか新規に作成したページに左上のセルを選んで右クリックで「形式を選択して貼り付け」で「行、列を入れ替える」を選んで「ｏｋ」を押す。
すると１列目に組が、２列目に名前の表が出来ます。あとは「データの並び替え」で組別、組順で名前が並びます。
これでいかがでしょうか。

補足

早速の回答ありがとうございます。

回答いただいた方法で列方向に組ごとにまとめることはできるのですが
画像Sheet2のように組毎に行方向まとめる方法（関数等）があればお教えいただきたいのです。
よろしくお願いします。