Excel 複雑な（？）行列の入れ替えについて

質問

こんにちは。
あるシステムから登録状況をExcelへ出力する作業をしていて、
その出力された表がわかりづらいので、見やすい表にしたいです。

システムから表の出力方法を変更することは出来ないようなので、
出力後に改編するしか無いのですが、うまいやり方が思いつきません。

【出力された表の状態】
　　氏名　　　　　　該当コード　 許可　　　 該当コード　　　許可・・・・・
日本　　 太郎　　　　　101　　　　○ 　　　　　 102　　　　　　○
大和　　 撫子　　　　　102　　　　○　　　　　　104　　　　　　○
Smith　Richard　　　　 103　　　　○

【最終的に以下のような表にしたいです】
　　氏名　　　　　　　 101　　　　102　　　103　　　 104・・・・・　
日本　　 太郎　　　　　 ○　　　 　○　　 　　✕　　　　✕
大和　　 撫子　　　　　 ✕　　　 　○　　 　　✕　　　　○
Smith　Richard　　 　　✕　　　 　✕　　 　　○　　　　✕

この「該当コード」の数が多いので、出力されたままの状態だと非常に見づらいのです。
単純に行列の入れ替えだとうまく行かず…。

「このコードに対しては、誰々が許可を持っている」というのをひと目で把握できると
とても助かるので、どうにか下の例のような状態にしたいです。
何かいい方法は無いでしょうか？

お知恵を拝借できればと思います。
どうぞよろしくお願いいたします。

回答No.5

mitarashi · ベストアンサー

最近連想配列のキーをソートして利用するのに凝っているので、試しにやってみました。
データは一番最初のシートのA1からあるとします。元のデータには、許可されたコードしか記載されていないと解釈しています。二番目のシートを作業用に使います（都度クリアするので注意）
変換後のデータは元表の下に書き出します。
なお、データが巨大で処理が重たい場合は、高速化の種もあります。

Sub test()
Dim sh As Worksheet
Dim targetRange As Range
Dim destCell As Range, destRange As Range
Dim i As Long, j As Long
Dim myDic As Object, myKey As String, mykeys As Variant

Set sh = ThisWorkbook.Sheets(1)
Set targetRange = sh.Range("A1").CurrentRegion
Set myDic = CreateObject("Scripting.Dictionary")
Set destCell = targetRange.Cells(targetRange.Rows.Count, 1).Offset(2, 0)
For i = 2 To targetRange.Rows.Count
For j = 2 To targetRange.Columns.Count Step 2
myKey = CStr(targetRange.Cells(i, j).Value)
If (Not myDic.exists(myKey)) And myKey <> "" Then myDic.Add myKey, ""
Next j
Next i
mykeys = myDic.keys
sortKeys mykeys
For i = LBound(mykeys) To UBound(mykeys)
myDic(mykeys(i)) = i
Next i
targetRange.Columns(1).Copy Destination:=destCell
destCell.Offset(0, 1).Resize(1, UBound(mykeys)).Value = mykeys
For i = 2 To targetRange.Rows.Count
For j = 2 To targetRange.Columns.Count Step 2
myKey = CStr(targetRange.Cells(i, j).Value)
If myDic.exists(myKey) Then destCell.Offset(i - 1, myDic(myKey)).Value = "○"
Next j
Next i
Set destRange = destCell.CurrentRegion
Set destRange = Intersect(destRange, destRange.Offset(1, 1))
destRange.SpecialCells(xlCellTypeBlanks).Value = "×"
End Sub

Sub sortKeys(ByRef mykeys As Variant)
Dim workSh As Worksheet
Dim sortRange As Range

Set workSh = ThisWorkbook.Sheets(2)
workSh.Cells.Clear
Set sortRange = workSh.Range("A1").Resize(UBound(mykeys) + 1, 1)
sortRange.NumberFormatLocal = "@"
sortRange.Value = Application.WorksheetFunction.Transpose(mykeys)
sortRange.Sort Key1:=sortRange.Range("A1"), Order1:=xlAscending
mykeys = Application.WorksheetFunction.Transpose(sortRange.Value)
End Sub

お礼

できました！ありがとうございます！
あとは表に色付け等していけばこのまま使えそうです。
これで大分作業効率が上がると思います。
元表がややこしいので無理かな？と諦めかけていたのですが、良かったです。
ありがとうございました！

回答No.4

noname#204879

添付図参照
Sheet2!B2: =IF(SUMPRODUCT((Sheet1!$A$2:$A$1000=$A2)*(Sheet1!$B$2:$Z$1000=B$1)),"○","×")

お礼

回答ありがとうございます。
頭が悪くてすみません、これをSheet2のB2セルに適用し、コピペしていけば良いのでしょうか？
なぜか全部○になってしまいます。
私がとんでもない勘違いをしている…？
あれこれ試してみることにします。
ありがとうございます。

回答No.3

kagakusuki

済みません、回答No.2に添付していた画像は、誤って別のＥｘｃｅｌのｂｏｏｋを写してしまったもので、表示結果に一部誤りがありました。
　正しい画像は以下の通りです。

お礼

画像をありがとうございます。わかりやすいです。
こちらでは綺麗に出来ているのに、私のほうが出来ていないということは
明らかに私のやり方がどこかで間違っているということですよね…

回答No.2

kagakusuki

前提条件として、該当コード欄に入力されているコードが全て数値データであり、例えば「A102」等の様な文字列データのコードは存在していない、と考えても良いのでしたら、以下の様な方法は如何でしょうか？
　尚、下記の方法では、許可の欄に入力されているデータの中に、「○」以外のデータが存在していても構いません。
　又、元データの表中における、該当者の行の中に、該当するコードが存在していても、その右隣の許可欄が空欄となっている場合には、許可がされていないと判断して、改編後の表の中の該当する箇所には「×」が表示されます。
　今仮に、システムから出力された表の中で「氏名」という項目名が入力されているセルが、Sheet1のA1セルであり、改編後の表をSheet2に表示させるものとします。

　まず、Sheet2のA1セルに次の関数を入力して下さい。

=Sheet1!$A$1

　次にSheet2のA2セルに次の関数を入力して下さい。

=IF(OFFSET(Sheet1!$A$1,ROWS($2:2),)="","",OFFSET(Sheet1!$A$1,ROWS($2:2),))

　次にSheet2のB1セルに次の関数を入力して下さい。

=IF(OR(A1="",COUNT(Sheet1!$B:$B)=0),"",IF(COUNTIF(INDEX(Sheet1!$B:$B,MATCH(9E+307,Sheet1!$B:$B)):INDEX(Sheet1!$1:$1,MATCH(CHAR(1),Sheet1!$1:$1,-1)),">"&IF(COLUMNS($B:B)=1,-9E+307,A1)),LARGE(INDEX(Sheet1!$B:$B,MATCH(9E+307,Sheet1!$B:$B)):INDEX(Sheet1!$1:$1,MATCH(CHAR(1),Sheet1!$1:$1,-1)),COUNTIF(INDEX(Sheet1!$B:$B,MATCH(9E+307,Sheet1!$B:$B)):INDEX(Sheet1!$1:$1,MATCH(CHAR(1),Sheet1!$1:$1,-1)),">"&IF(COLUMNS($B:B)=1,-9E+307,A1))),""))

　次にSheet2のB2セルに次の関数を入力して下さい。

=IF(OR($A2="",B$1=""),"",IF(ISERROR(1/(OFFSET(Sheet1!$A$1,MATCH($A2,Sheet1!$A:$A,0)-ROW(Sheet1!$A$1),MATCH(B$1,OFFSET(Sheet1!$1:$1,MATCH($A2,Sheet1!$A:$A,0)-ROW(Sheet1!$A$1),),0)-COLUMN(Sheet1!$A$1)+1)<>"")),"×",OFFSET(Sheet1!$A$1,MATCH($A2,Sheet1!$A:$A,0)-ROW(Sheet1!$A$1),MATCH(B$1,OFFSET(Sheet1!$1:$1,MATCH($A2,Sheet1!$A:$A,0)-ROW(Sheet1!$A$1),),0)-COLUMN(Sheet1!$A$1)+1)))

　次にSheet2のB1～B2の範囲をコピーして、表中において同じ行範囲のB列よりも右側にある全ての列上のセルに貼り付けて下さい。
　次に、Sheet2の2行目全体をコピーして、Sheet2の3行目以下に貼り付けて下さい。

　以上です。

この投稿のマルチメディアは削除されているためご覧いただけません。

お礼

回答ありがとうございます。
はい、コード欄に文字列はなく、数字のみ（「101」「305」など）です。

なぜでしょうか…途中までしか表示されません。
コピペしていく途中で、ペーストしても空白になり、
念のため数列ペーストを続け、その後行ごとコピペしますが、
下の行も同じく、途中の列までの表示になります。
やはり元の表の形式も変えないとダメ…？非表示になっている列・行なども無いのですが…。フィルターもデフォルトでは付いていますが、解除してからやっています。

関数で色々出来ることに感動しました。勉強しないとだめですね。
ありがとうございます！

回答No.1

tom04

こんにちは！
VBAになってしまいますが、一例です。
Sheet1のデータをSheet2に表示するようにしてみました。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, endRow As Long, endCol As Long
Dim c As Range, r As Range, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
endRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
endCol = wS1.Cells(1, Columns.Count).End(xlToLeft).Column
wS2.Cells.Clear
wS1.Range("A:A").Copy wS2.Range("A1")
For Each c In Range(wS1.Cells(2, "B"), wS1.Cells(endRow, endCol))
If IsNumeric(c) Then
Set r = wS2.Rows(1).Find(what:=c, LookIn:=xlValues, lookat:=xlWhole)
If r Is Nothing Then
wS2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = c
End If
End If
Next c
endCol = wS2.Cells(1, Columns.Count).End(xlToLeft).Column
Range(wS2.Cells(1, "B"), wS2.Cells(1, endCol)).Sort key1:=wS2.Cells(1, "B"), _
order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
For i = 2 To endRow
For j = 2 To wS1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2
Set c = wS2.Rows(1).Find(what:=wS1.Cells(i, j), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
wS2.Cells(i, c.Column) = wS1.Cells(i, j + 1)
End If
Next j
Next i
With wS2.Range("A1").CurrentRegion
.SpecialCells(xlCellTypeBlanks) = "×"
.Borders.LineStyle = xlContinuous
End With
End Sub 'この行まで

こんな感じではどうでしょうか？m（_ _）m

お礼

回答ありがとうございます。
なぜでしょう…なぜか途中のコード＆許可欄までしか表示されないです。
中身の数字や名前を変えてみたりしましたが、なぜそうなってしまうか規則性が発見できません。
元の表に何か問題があるんでしょうか。
これで出来れば、一発で手間が済むので非常に楽ですよね。もう少しで出来そうなのですが…。
マクロを勉強しないとと実感しました。とても便利ですね。
触ったことがなかったので（普段ごく基本のみ）、実行のやり方もお教えいただけて良かったです。
ありがとうございます！