Excel 複数あるシートのデータを1枚にまとめる

質問

複数あるシートのデータを1枚にまとめたいです。

シートの作りが私にとっては複雑で・・・一人でできそうにもありません。
構成は下記のようになっています。

列Aに機材名・その機材のバージョン・名前・その人の個人IDが書かれています。

○○システム
バージョン2.0
山田
ABCDE
佐藤
ACEDF
バージョン2.1
永田
DEFCD
・
・
・
▲▲システム
バージョン1.0
渋谷
UUIOP
バージョン2.0
・
・
・

という感じです。
こんなデータが50数枚のシートにそれぞれあります。
どのように1枚にまとめたいかといいますと、
１行目に名前・ID・機材名とバージョンずらずらずら
２行目から個人名・その人のID・1行目に書いている機材を使用しているか（使用していたら○をつけたい）
という感じです。

Excel初心者で、キャパ越えで困っています。
縦列につらつらつら～っと書かれているせいで、どうこれを行に移して名前とIDと機材名を関連つけるか悩んでいます。

どうか力を貸してください・・・
宜しくお願いいたします。

回答No.3

tom04 · ベストアンサー

No.1・2です！
何度もお邪魔します。

今までの投稿は両方とも無視してください。
少し長くなりますが、今までの二つのコードをまとめてみました。
ただし、前提条件があります。

（1）新しいSheetを挿入し、Sheet見出しの一番左側に配置しておく。
（2）Sheet2以降のデータはA列の1行目からある。（Sheet数はいくつでも構いません）
（3）質問文にある「ABCDE」等のアルファベットセルがIDセルで、半角英数で入力してある。
（4）同姓同名は構いませんが、IDに重複はない
（5）「機材名」は「○○システム」のように「システム」という語句が入っている。
（6）バージョンセルも「バージョン2.0」のように「バージョン」という語句が入っている
（7）元データの並びが変わってしまうがそれでも構わない

以上を踏まえた上での一例です。

Alt+F11キー　→　画面左下の「ThisWorkbook」をダブルクリック　→　
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub 各Sheet集計() 'この行から
Dim i, j, k, L As Long
Dim ws As Worksheet
Set ws = Worksheets(1)
Dim buf1, buf2 As String
ws.Cells.ClearContents
ws.Cells(1, 1) = "氏名"
ws.Cells(1, 2) = "ID"
Application.ScreenUpdating = False
For k = 2 To Worksheets.Count
For i = Sheets(k).Cells(Rows.Count, 1).End(xlUp).Row To 6 Step -1
If LenB(StrConv(Sheets(k).Cells(i, 1), vbFromUnicode)) = Len(Sheets(k).Cells(i, 1)) Then
If Not Sheets(k).Cells(i - 2, 1) Like "バージョン" & "*" And Not Sheets(k).Cells(i - 3, 1) _
Like "*" & "システム" And LenB(StrConv(Sheets(k).Cells(i - 2, 1), vbFromUnicode)) = _
Len(Sheets(k).Cells(i - 2, 1)) Then
Range(Sheets(k).Cells(i - 1, 1), Sheets(k).Cells(i, 1)).Insert (xlDown)
ElseIf Sheets(k).Cells(i - 2, 1) Like "バージョン" & "*" And Not Sheets(k).Cells(i - 3, 1) _
Like "*" & "システム" Then
Sheets(k).Cells(i - 2, 1).Insert (xlDown)
End If
End If
Next i
For i = 1 To Sheets(k).Cells(Rows.Count, 1).End(xlUp).Row
If Sheets(k).Cells(i, 1) Like "*" & "システム" Then
buf1 = Sheets(k).Cells(i, 1)
ElseIf Sheets(k).Cells(i, 1) Like "バージョン" & "*" Then
buf2 = Sheets(k).Cells(i, 1)
End If
If Sheets(k).Cells(i, 1) = "" And Sheets(k).Cells(i + 1, 1) = "" Then
Sheets(k).Cells(i, 1) = buf1
Sheets(k).Cells(i + 1, 1) = buf2
ElseIf Sheets(k).Cells(i, 1) = "" And Sheets(k).Cells(i + 1, 1) Like "バージョン" & "*" Then
Sheets(k).Cells(i, 1) = buf1
End If
Next i
Next k
For k = 2 To Worksheets.Count
For i = 1 To Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Row Step 4
If WorksheetFunction.CountIf(ws.Columns(1), Sheets(k).Cells(i, 1) & vbCrLf & Sheets(k).Cells(i + 1, 1)) = 0 Then
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = Sheets(k).Cells(i, 1) & vbCrLf & Sheets(k).Cells(i + 1, 1)
End If
Next i
Next k
L = ws.Cells(Rows.Count, 1).End(xlUp).Row
Range(ws.Cells(2, 1), ws.Cells(L, 1)).Sort key1:=ws.Cells(1, 1), order1:=xlAscending
For j = 2 To L
ws.Cells(1, j + 1) = ws.Cells(j, 1)
Next j
Range(ws.Cells(2, 1), ws.Cells(L, 1)).ClearContents
For k = 2 To Worksheets.Count
For i = 4 To Sheets(k).Cells(Rows.Count, 1).End(xlUp).Row Step 4
If WorksheetFunction.CountIf(ws.Columns(2), Sheets(k).Cells(i, 1)) = 0 Then
With ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = Sheets(k).Cells(i - 1, 1)
.Offset(, 1) = Sheets(k).Cells(i, 1)
End With
End If
Next i
Next k
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
For k = 2 To Worksheets.Count
For L = 1 To Sheets(k).Cells(Rows.Count, 1).End(xlUp).Row Step 4
If ws.Cells(1, j) = Sheets(k).Cells(L, 1) & vbCrLf & Sheets(k).Cells(L + 1, 1) Then
If ws.Cells(i, 2) = Sheets(k).Cells(L + 3, 1) Then
ws.Cells(i, j) = "○"
End If
End If
Next L
Next k
Next j
Next i
Application.ScreenUpdating = True
j = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Range(ws.Columns(1), ws.Columns(j)).AutoFit
End Sub 'この行まで

※　一旦マクロを実行すると元に戻せませんので別Bookす何枚かのSheetをコピー＆ペーストしてマクロをためしてみてください。

以上、ご希望通りの動きになれば良いのですが・・・m（＿ ＿）m

お礼

tom04さん

こんにちは、はじめまして。
すごく丁寧にアドバイスをくださり、ありがとうございます！
私の説明が稚拙で・・・
「バージョン」や「システム」といった言葉は必ず含められていないんです。
わかりやすくするために書いたのですが、逆に足手まといになってしまいました・・・

もしよろしければ・・・
もう一度、きちんと画像付で質問をさせていただいたので、見ていただけないでしょうか＞＜
http://oshiete.goo.ne.jp/qa/7079053.html
本当にわがままで申し訳ないです。
週末マクロを勉強してみましたがちんぷんかんぷんでした・・・

宜しくお願いいたします。

回答No.4

kagakusuki

機材名には必ず「システム」という文字列が含まれていて、且つ、機材名が入力されているセル以外のセルに入力されている文字列には「システム」という文字列は、絶対に含まれておらず、
バージョン名には必ず「バージョン」という文字列が入っていて、且つ、バージョン名が入力されているセル以外のセルに入力されている文字列には「バージョン」という文字列は、絶対に含まれていないものと考えれば宜しいのでしょうか？
　もし、上記の条件に基づいて、機材名とバージョン名を、文字列と区別する事が出来るのでしたら、以下の様な方法を使う事が出来ます。

　複数列の作業列と関数を使った方法です。
　今仮に、「補助」という名称のシートのA列～M列を作業列として使用して、「一覧」という名称のシートにデータをまとめるものとします。
　まず、補助シートのA2以下に、元データが入力されている50数枚のシートの、各シート名を全て並べて入力して下さい。
　次に、補助シートのC1セルに

0

という数値を入力して下さい。
　次に、補助シートのC2セルに次の数式を入力して下さい。

=IF(ISNUMBER(MATCH("゛",INDIRECT($A2&"!A:A"),-1)),MATCH("゛",INDIRECT($A2&"!A:A"),-1),"")

　次に、補助シートのD1セルに次の数式を入力して下さい。

=IF(ISNUMBER($C1),SUM($C$1:$C1)+1,"")

　次に、補助シートのE1セルに次の数式を入力して下さい。

=IF(ROWS($1:1)>SUM($C:$C),"",INDIRECT(INDEX($A:$A,MATCH(ROWS($1:1),$D:$D)+1)&"!A"&ROWS($1:1)-VLOOKUP(ROWS($1:1),$D:$D,1)+1))

　次に、補助シートのE1セルに次の数式を入力して下さい。

=IF(ROWS($1:1)>SUM($C:$C),"",INDIRECT(INDEX($A:$A,MATCH(ROWS($1:1),$D:$D)+1)&"!A"&ROWS($1:1)-VLOOKUP(ROWS($1:1),$D:$D,1)+1))

　次に、補助シートのF1セルに次の数式を入力して下さい。

=IF(ISNUMBER(FIND("システム",$E1)),ROW(),"")

　次に、補助シートのG1セルに次の数式を入力して下さい。

=IF(ISNUMBER(FIND("バージョン",$E1)),ROW(),"")

　次に、補助シートのH2セルに次の数式を入力して下さい。

=IF(AND($E2<>"",MAX($F$1:$F2)<MAX($G$1:$G2)),INDEX($E:$E,MAX($F$1:$F2))&INDEX($E:$E,MAX($G$1:$G2))&"゛"&COUNTIF(H$1:H1,"="&INDEX($E:$E,MAX($F$1:$F2))&INDEX($E:$E,MAX($G$1:$G2))&"゛*"),"")

　次に、補助シートのI2セルに次の数式を入力して下さい。

=IF(AND(ISNUMBER(FIND("システム",$E2)),COUNTIF($E$1:$E2,$E2)=1),ROW(),"")

　次に、補助シートのJ2セルに次の数式を入力して下さい。

=IF(AND(ISNUMBER($G2),COUNTIF($H$1:$H2,$H2)=1),INDEX($E:$E,MAX($F$1:$F2))&"゛"&COUNTIF(J$1:J1,"="&INDEX($E:$E,MAX($F$1:$F2))&"゛*")+1,"")

　次に、補助シートのK2セルに次の数式を入力して下さい。

=IF($J2="","",MAX($F$1:$F2))

　次に、補助シートのL2セルに次の数式を入力して下さい。

=IF(AND(VLOOKUP(ROW(),$D:$D,1)<MAX($G$1:$G2),COUNT($F2,$G2)=0,MOD(ROW()-MAX($G$1:$G2),2)=1),ROW(),"")

　次に、補助シートのM2セルに次の数式を入力して下さい。

=IF(AND(ISNUMBER($L1),COUNTIF($E$1:$E2,$E2)=1),ROW(),"")

　次に、補助シートのD1～G1の範囲をコピーして、補助シートのD2～G2の範囲に貼り付けて下さい。
　次に、補助シートのC2～M2の範囲をコピーして、同じ列の3行目以下に貼り付けて下さい。

　次に、一覧シートのA1セルに「名前」と入力して下さい。
　次に、一覧シートのB1セルに「ID」と入力して下さい。
　次に、一覧シートのA1セルとA2セルを結合して下さい。
　次に、一覧シートのB1セルとB2セルを結合して下さい。
　次に、一覧シートのC1セルに次の数式を入力して下さい。

=IF(COLUMNS($C:C)>COUNT(補助!$K:$K),"",IF(IF(COLUMNS($C:C)>1,SMALL(補助!$K:$K,COLUMNS($C:C))=SMALL(補助!$K:$K,COLUMNS($C:C)-1),),"",INDEX(補助!$E:$E,SMALL(補助!$K:$K,COLUMNS($C:C)))))

　次に、一覧シートのC2セルに次の数式を入力して下さい。

=IF(COLUMNS($C:C)>COUNTIF(補助!$J:$J,"*?"),"",INDEX(補助!$E:$E,MATCH(INDEX(補助!$E:$E,SMALL(補助!$I:$I,COUNTIF($C$1:C$1,"*?")))&"゛"&COLUMNS($B:C)-MATCH(INDEX(補助!$E:$E,SMALL(補助!$I:$I,COUNTIF($C$1:C$1,"*?"))),$B$1:C$1,0)+1,補助!$J:$J,0)))

　次に、一覧シートのB3セルに次の数式を入力して下さい。

=IF(ROWS($A$3:$A3)>COUNT(補助!$M:$M),"",INDEX(補助!$E:$E,SMALL(補助!$M:$M,ROWS($A$3:$A3))))

　次に、一覧シートのA3セルに次の数式を入力して下さい。

=IF($B3="","",INDEX(補助!$E:$E,MATCH($B3,補助!$E:$E,0)-1))

　次に、一覧シートのC3セルに次の数式を入力して下さい。

=IF(COUNTIF(補助!$H:$H,"="&INDEX(補助!$E:$E,SMALL(補助!$K:$K,COLUMNS($C:C)))&C$2&"゛"&$B3),"○","")

　次に、一覧シートのA3～C3の範囲をコピーして、同じ列の4行目以下に（機材の使用者の人数を上回るのに充分な行数となるまで）貼り付けて下さい。
　次に、一覧シートのC列全体をコピーして、C列よりも右側にある列範囲に（機材の全バージョンの数の総数を上回るのに充分な列数となるまで）貼り付けて下さい。

　後は、補助シートのA2以下に、元データが入力されている、各シートのシート名を並べて入力しますと、一覧シートの表に、使用者の名前とID、及び、機材名とバージョン名が自動的に重複無しに表示され、使用した機材を示す列と、使用者を示す行が交差した処に、丸印が表示されます。

お礼

kagakusukiさん

こんにちは、はじめまして。
とても丁寧にアドバイスをくださり、ありがとうございます！
画像までくださり・・・！
まさにそのような感じで作成したいんです＞＜
しかし私の説明が稚拙で・・・
「バージョン」や「システム」といった言葉は必ず含められていないんです。
わかりやすくするために書いたのですが、逆に足手まといになってしまいました・・・

もしよろしければ・・・
もう一度、きちんと画像付で質問をさせていただいたので、見ていただけないでしょうか＞＜
http://oshiete.goo.ne.jp/qa/7079053.html
本当にわがままで申し訳ないです。
週末マクロを勉強してみましたがちんぷんかんぷんでした・・・

宜しくお願いいたします。

回答No.2

tom04

No.1です！
前回は
＞１行目に名前・ID・機材名とバージョンずらずらずら・・・
の部分を考慮していませんでした。
結局1行目に
「○○システム　バージョン××」のような感じの項目が必要な訳ですよね？

そうなると各Sheetが↓の画像になるように手を加える必要があると思います。
そのためには何か規則性を見つけなければならないのですが、
一つだけ！「ID」が半角英数という大前提があれば↓のコードで可能だと思います。

各SheetともA列1行目からデータがあるとして、画像の左側のようになるようなコードだけ載せておきます。

Alt+F11キー　→　画面左側の「ThisWorkbook」をダブルクリック　→　↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub 各Sheet調整() 'この行から
Dim i, k As Long
Dim buf1, buf2 As String
Application.ScreenUpdating = False
For k = 1 To Worksheets.Count
For i = Sheets(k).Cells(Rows.Count, 1).End(xlUp).Row To 6 Step -1
If LenB(StrConv(Sheets(k).Cells(i, 1), vbFromUnicode)) = Len(Sheets(k).Cells(i, 1)) Then
If Not Sheets(k).Cells(i - 2, 1) Like "バージョン" & "*" And Not Sheets(k).Cells(i - 3, 1) _
Like "*" & "システム" And LenB(StrConv(Sheets(k).Cells(i - 2, 1), vbFromUnicode)) = _
Len(Sheets(k).Cells(i - 2, 1)) Then
Range(Sheets(k).Cells(i - 1, 1), Sheets(k).Cells(i, 1)).Insert (xlDown)
ElseIf Sheets(k).Cells(i - 2, 1) Like "バージョン" & "*" And Not Sheets(k).Cells(i - 3, 1) _
Like "*" & "システム" Then
Sheets(k).Cells(i - 2, 1).Insert (xlDown)
End If
End If
Next i
For i = 1 To Sheets(k).Cells(Rows.Count, 1).End(xlUp).Row
If Sheets(k).Cells(i, 1) Like "*" & "システム" Then
buf1 = Sheets(k).Cells(i, 1)
ElseIf Sheets(k).Cells(i, 1) Like "バージョン" & "*" Then
buf2 = Sheets(k).Cells(i, 1)
End If
If Sheets(k).Cells(i, 1) = "" And Sheets(k).Cells(i + 1, 1) = "" Then
Sheets(k).Cells(i, 1) = buf1
Sheets(k).Cells(i + 1, 1) = buf2
ElseIf Sheets(k).Cells(i, 1) = "" And Sheets(k).Cells(i + 1, 1) Like "バージョン" & "*" Then
Sheets(k).Cells(i, 1) = buf1
End If
Next i
Next k
Application.ScreenUpdating = True
End Sub 'この行まで

※　各Sheetの変更が許されない場合はコードを手直しする必要があります。

尚、その後の新しいシートへの表示はもう少し待ってください。
（外出する用事があるため、時間が取れれば再度挑戦したいと思っています）

上記投稿（各Sheetの変更）がダメならごめんなさいね。m（＿ ＿）m

回答No.1

tom04

こんばんは！
外しているかもしれませんが・・・
「システム」は無視しても良いわけですよね？
VBAの一例です。

各SheetともA列のみのデータで、
「機材名」（バージョン○○）の下のセルに「氏名」・その下のセルに「ID」が入っているという前提での方法です。
当然のことながらIDに重複はない！（同姓同名があっても構いません）としています。

Sheet数はいくつあっても構いませんので、ワークシートを一つ挿入し
画面左下のSheet見出しの一番左側に配置しておきます。

そうした上で、Alt+F11キー　→　VBE画面が出ますので、画面左下の「ThisWorkbook」をダブルクリックし、↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j, k, L As Long
Dim ws As Worksheet
Set ws = Worksheets(1)
ws.Cells.ClearContents
Application.ScreenUpdating = False
For k = 2 To Worksheets.Count
For i = 1 To Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets(k).Cells(i, 1) Like "バージョン" & "*" And _
WorksheetFunction.CountIf(ws.Rows(1), Worksheets(k).Cells(i, 1)) = 0 Then
ws.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = Worksheets(k).Cells(i, 1)
End If
Next i
Next k
ws.Columns(1).Insert
For k = 2 To Worksheets.Count
For i = 1 To Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets(k).Cells(i, 1) Like "バージョン" & "*" And _
WorksheetFunction.CountIf(ws.Columns(2), Worksheets(k).Cells(i + 2, 1)) = 0 Then
With ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = Worksheets(k).Cells(i + 1, 1)
.Offset(, 1) = Worksheets(k).Cells(i + 2, 1)
End With
End If
Next i
Next k
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
For k = 2 To Worksheets.Count
For L = 1 To Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets(k).Cells(L, 1) = ws.Cells(1, j) And Worksheets(k).Cells(L + 1, 1) = ws.Cells(i, 1) Then
ws.Cells(i, j) = "○"
End If
Next L
Next k
Next j
Next i
ws.Cells(1, 1) = "氏名"
ws.Cells(1, 2) = "ID"
Application.ScreenUpdating = True
j = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Range(ws.Columns(1), ws.Columns(j)).AutoFit
End Sub 'この行まで

※　ワークシート挿入は一度だけでOKです。
※　マクロは何度実行されても構いません。

無理矢理やってみましたが、望み通りにならなかったらごめんなさいね。m（＿ ＿）m