***** 【Sheet2】 *****
　　　　Ａ　　　　　　Ｂ　　　　　　Ｃ　　　　　　Ｄ
1　生徒名　　　クラブ名　　クラブ名　　クラブ名
2　一太郎　　　野球部　　　書道部
3　花子　　　　 野球部　　　テニス部　 音楽部
4　黒子　　　 　野球部　　　水泳部　　 音楽部
5　三太郎　 　 テニス部　　書道部
6　二太郎　 　 野球部　　　水泳部

　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

Sub test()
　Dim WS(1 To 4) As Worksheet
　Dim LastRow(1 To 4) As Long
　Dim PathName As String
　Dim ArrBook As Variant
　Dim i As Long
　'画面の動きを固定
　Application.ScreenUpdating = False
　'データファイルを開く
　PathName = ThisWorkbook.Path & "\"
　ArrBook = Array("data1.xls", "data2.xls", "data3.xls")
　For i = LBound(ArrBook) To UBound(ArrBook)
　　Workbooks.Open PathName & ArrBook(i)
　Next
　'オブジェクト変数を設定
　Set WS(1) = Workbooks("data1.xls").Worksheets("Sheet1")
　Set WS(2) = Workbooks("data2.xls").Worksheets("Sheet2")
　Set WS(3) = Workbooks("data3.xls").Worksheets("Sheet3")
　Set WS(4) = ThisWorkbook.Worksheets("Sheet4")
　With WS(4)
　　'Sheet4をクリア→見出し記入
　　.Cells.ClearContents
　　.Cells(1, 1) = "品番"
　　.Cells(1, 2) = "サイズ"
　　.Cells(1, 3) = "数量"
　　'各シートの最終行を取得
　　LastRow(1) = WS(1).Range("A65536").End(xlUp).Row
　　LastRow(2) = WS(2).Range("A65536").End(xlUp).Row
　　LastRow(3) = WS(3).Range("A65536").End(xlUp).Row
　　'各シートの内容をSheet4に貼り付ける
　　For i = 1 To 3
　　　LastRow(4) = .Range("A65536").End(xlUp).Row + 1
　　　WS(i).Rows("2:" & LastRow(i)).Copy .Cells(LastRow(4), 1)
　　Next i
　　'Sheet4の最終行を取得
　　LastRow(4) = .Range("A65536").End(xlUp).Row
　　'A列を昇順にソート
　　.Range("A1").Sort Key1:=.Range("A1"), Header:=xlYes
　　'同じ品番の数量を集計する
　　For i = LastRow(4) To 3 Step -1
　　　If .Cells(i, 1) = .Cells(i - 1, 1) Then
　　　　.Cells(i - 1, 3) = .Cells(i - 1, 3) + .Cells(i, 3)
　　　　.Rows(i).ClearContents
　　　End If
　　Next i
　　'空白行削除
　　.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　End With
　'オブジェクト変数を初期化
　For i = 1 To 4
　　Set WS(i) = Nothing
　Next i
　'データファイルを閉じる
　For i = LBound(ArrBook) To UBound(ArrBook)
　　Workbooks(ArrBook(i)).Close SaveChanges:=False
　Next
　'画面の固定を解除
　Application.ScreenUpdating = True
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。
　　コードはtotal.xlsの標準モジュールに記入してください。

重複しない値を抽出するには？
http://cgi.fuji.ne.jp/~fj2094/cgi-bin2/wwwlng.cgi?print+200012/00120032.txt
　「重複リストの削除」　【関数ラウンジ】

A列に元データがあるとして、最高100行までに対応
　B1に、=IF(COUNTIF(A$1:A1,A1)=1,ROW(),"")
　C1に、=IF(ISERROR(INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1)),"",
　　　　　　　　　　　　　　　　INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1))　　（一行で記入）
そのままドラッグします。

【解析】

　B1の関数　=IF(COUNTIF(A$1:A1,A1)=1,ROW(),"")
　　A$1:A1範囲の中で、A1の値の数が1の場合、その行番号を返し、1でなければ空白にする

　C1の関数　=IF(ISERROR(INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1)),"",
　　　　　　　　　　　　　　　　INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1))

　　ISERROR(INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1))
　　　(INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1))の値がエラーかどうか判定

　　INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1)
　　　$A$1:$A$100の範囲で、　SMALL($B$1:$B$100,ROW())　行目、1列目の値を返す

　　SMALL($B$1:$B$100,ROW())
　　　$B$1:$B$100の範囲で、ROW()番目に小さい値を返す。ROW()は、その行の行番号
　

上のような表を、新しくシートを挿入して下のように表示します。元のデータシートを sheet1 としています。

Sub miko_test()
　Dim WS1 As Worksheet, WS2 As Worksheet
　Dim i As Long, j As Integer
　Dim a As Long, b As Integer, c As Long
　'処理するシートの名前を変更に格納
　Set WS1 = Worksheets("sheet1")　　　　　　　　　
　Application.ScreenUpdating = False '画面の動きを固定
　'右側にシートを追加
　ActiveWorkbook.Sheets.Add After:=WS1
　Set WS2 = Worksheets(ActiveSheet.Name)
　a = 1 '該当行
　b = 2 '該当列
　With WS1
　　'sheet1の1行目から最終行まで処理
　　For i = 1 To .Cells(Application.Rows.Count, 1).End(xlUp).Row
　　　'sheet1、AB列を転記
　　　Cells(a, 1) = .Cells(i, 1)
　　　Cells(a, 2) = .Cells(i, 2)
　　　c = a '該当項目の最初の行を取得
　　　'sheet1の2列目から最終列まで処理
　　　For j = 2 To .Cells(i, .Application.Columns.Count).End(xlToLeft).Column
　　　　If .Cells(i, j + 1) = "" Then Exit For
　　　　If .Cells(i, j) = .Cells(i, j + 1) Then '左のセルと値が同じ場合
　　　　　a = a + 1
　　　　　Cells(a, b) = .Cells(i, j + 1)
　　　　Else '左のセルと値が違う場合
　　　　　b = b + 1
　　　　　a = c
　　　　　Cells(a, b) = .Cells(i, j + 1)
　　　　End If
　　　Next j
　　　b = 2
　　　'使用範囲内の最終行取得
　　　a = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
　　Next i
　End With
　Application.ScreenUpdating = True '画面の固定を解除
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

Sub miko_test1()
Dim i As Integer, j As Long, g As Long
'抽出前の最終行を取得
g = Cells(Application.Rows.Count, 1).End(xlUp).Row
'６行目から１列目のデータがなくなるまで繰り返し
j = 6
Do
'１列目から３行目の最終列まで繰り返し
For i = 1 To Cells(3, Application.Columns.Count).End(xlToLeft).Column
If Cells(4, i) = Cells(j, i) Then
Rows("5").Insert Shift:=xlDown
Rows(j + 1).Copy Range("A5")
j = j + 1
Exit For
End If
Next
j = j + 1
If Cells(j, 1) = "" Then Exit Do
Loop
'抽出最終行取得
If Cells(Application.Rows.Count, 1).End(xlUp).Row > g Then
g = Cells(Application.Rows.Count, 1).End(xlUp).Row - g
If MsgBox("抽出分をクリアしていいですか？", vbOKCancel + vbQuestion) = vbOK Then
Rows("5:" & g + 4).Delete Shift:=xlUp
Else
MsgBox "抽出行を削除しませんでした。5行目から" & g + 4 & "行目まで抽出しています"
End If
Else
MsgBox "抽出したデータはありませんでした"
End If
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

Sub miko_test2()
　Dim i As Integer, j As Long, g As Long, k As Integer, m As Integer
　'抽出前の最終行を取得
　g = Cells(Application.Rows.Count, 1).End(xlUp).Row
　'６行目から１列目のデータがなくなるまで繰り返し
　j = 6
　Do
　　'１列目から３行目の最終列まで繰り返し
　　For i = 1 To Cells(3, Application.Columns.Count).End(xlToLeft).Column
　　　If Cells(4, i) <> "" And Cells(4, i) <> Cells(j, i) Then
　　　　'品名検索
　　　　If i = 2 Then
　　　　　For k = 1 To Len(Cells(j, 2))
　　　　　　If Mid(Cells(j, 2), k, Len(Cells(4, 2))) = Cells(4, 2) Then
　　　　　　　GoTo pro2 '抽出チェックを継続
　　　　　　End If
　　　　　Next
　　　　End If
　　　　GoTo pro1 '抽出処理を飛ばす
　　　End If
pro2:
　　Next
　　Rows("5").Insert Shift:=xlDown
　　Rows(j + 1).Copy Range("A5")
　　j = j + 1
　　MsgBox j & "行目を抽出"
pro1:
　　j = j + 1
　　If Cells(j, 1) = "" Then Exit Do
　Loop
　'抽出最終行取得
　If Cells(Application.Rows.Count, 1).End(xlUp).Row > g Then
　　g = Cells(Application.Rows.Count, 1).End(xlUp).Row - g
　　If MsgBox("抽出分をクリアしていいですか？", vbOKCancel + vbQuestion) = vbOK Then
　　　Rows("5:" & g + 4).Delete Shift:=xlUp
　　Else
　　　MsgBox "抽出行を削除しませんでした。5行目から" & g + 4 & "行目まで抽出しています"
　　End If
　Else
　　MsgBox "抽出したデータはありませんでした"
　End If
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

処理する候補のセル範囲（上の例だとA2〜A4）を選択してから実行してください。
Sub miko_test()
　Dim i As Long, j As Integer, retu As Integer
　Dim m As Long, mm As Long, n As Integer
　'選択対象がセルでなければ､マクロを中止
　If Not TypeName(Selection) = "Range" Then Exit Sub
　m = Selection.Row '選択範囲の最初の行
　mm = Selection.Rows(Selection.Rows.Count).Row '選択範囲の最後の行
　n = Selection.Columns(1).Column '選択範囲の最初の列
　retu = n + 2 '選択範囲の２列右隣の列
　'選択範囲の最初の行から最後の行まで繰り返し
　For i = m To mm
　　For j = i + 1 To mm
　　　'選択範囲の右隣の列の最終行に記入
　　　Cells(Cells(Application.Rows.Count, retu).End(xlUp).Row + 1, retu) = _
　　　Cells(i, n) & " と " & Cells(j, n) & " の合計"
　　　Cells(Cells(Application.Rows.Count, retu).End(xlUp).Row, retu + 1) = _
　　　Cells(i, n) + Cells(j, n)
　　Next
　Next
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

Sub miko_test2()
　Dim i As Long, j As Long, k As Long, m As Long, n As Long
　'B列の最初の行から最後の行まで繰り返し
　For i = 2 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　'２組の組み合わせ
　　For j = i + 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　　'選択範囲の右隣の列の最終行に記入
　　　Cells(Cells(Application.Rows.Count, 4).End(xlUp).Row + 1, 4) = _
　　　Cells(i, 1) & " と " & Cells(j, 1) & " の平均"
　　　Cells(Cells(Application.Rows.Count, 4).End(xlUp).Row, 5) = _
　　　(Cells(i, 2) + Cells(j, 2)) / 2
　　　'３組の組み合わせ
　　　For k = j + 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　　　Cells(Cells(Application.Rows.Count, 7).End(xlUp).Row + 1, 7) = _
　　　　Cells(i, 1) & " と " & Cells(j, 1) & " と " & _
　　　　Cells(k, 1) & " の平均"
　　　　Cells(Cells(Application.Rows.Count, 7).End(xlUp).Row, 8) = _
　　　　(Cells(i, 2) + Cells(j, 2) + Cells(k, 2)) / 3
　　　　'４組の組み合わせ
　　　　For m = k + 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　　　　Cells(Cells(Application.Rows.Count, 10).End(xlUp).Row + 1, 10) = _
　　　　　Cells(i, 1) & " と " & Cells(j, 1) & " と " & _
　　　　　Cells(k, 1) & " と " & Cells(m, 1) & " の平均"
　　　　　Cells(Cells(Application.Rows.Count, 10).End(xlUp).Row, 11) = _
　　　　　(Cells(i, 2) + Cells(j, 2) + Cells(k, 2) + _
　　　　　Cells(m, 2)) / 4
　　　　　'５組の組み合わせ
　　　　　For n = m + 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　　　　　Cells(Cells(Application.Rows.Count, 13).End(xlUp).Row + 1, 13) = _
　　　　　　Cells(i, 1) & " と " & Cells(j, 1) & " と " & _
　　　　　　Cells(k, 1) & " と " & Cells(m, 1) & " と " & _
　　　　　　Cells(n, 1) & " の平均"
　　　　　　Cells(Cells(Application.Rows.Count, 13).End(xlUp).Row, 14) = _
　　　　　　(Cells(i, 2) + Cells(j, 2) + Cells(k, 2) + _
　　　　　　Cells(m, 2) + Cells(n, 2)) / 5
　　　　　Next
　　　　Next
　　　Next
　　Next
　Next
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。