それぞれの行ごとに、同じ数値が重なった回数ごとに値をソートして並べるものです。
また、その個数も付けてください。
下の画像のような感じです。
http://f.hatena.ne.jp/HLYGRL/20080630175522
VBA初心者なので各マクロの説明などもよろしくお願いします。
#また、文字制限のため、サンプルデータと作っていただきたいもののサンプル例(上記URLと同じ)を
この下にある「この質問・回答へのコメント」に記載します。
データ元の表が左上詰めで作成されているとして、新規シートを作ってそこに図と同じ集計表を作るマクロです。
データ行は3行以上にも対応させています。
指定が無かったので、数値は出てきた順に縦に並びます。大きさ順ならば修正します。
重なった回数は各Partごとに最大個数まで数値が入るようにしています。
Option Explicit Sub Macro() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim h1() As Double Dim h2() As Integer Dim LastRow As Long '最終行 Dim LastColumn As Integer '各行の最終列 Dim useColumn As Integer Dim useRow As Long '作業用変数 Dim i As Long Dim j As Integer Dim k As Integer Dim l As Integer Dim m As Integer Dim count As Integer 'シート名は実際の環境に合わせてください Set ws1 = ActiveSheet 'データシート Set ws2 = Worksheets.Add '集計先シート ws2.Range("A2").Value = "重なった回数" ws2.Range("A3").Value = "その値" LastRow = ws1.Range("A" & Rows.count).End(xlUp).Row For i = 2 To LastRow useColumn = ws2.UsedRange.Columns.count LastColumn = ws1.Cells(i, Columns.count).End(xlToLeft).Column For j = 2 To LastColumn count = 0 For k = 2 To LastColumn If ws1.Cells(i, j).Value = ws1.Cells(i, k) Then count = count + 1 End If Next k l = 3 While ws2.Cells(l, useColumn + count) <> "" And ws2.Cells(l, useColumn + count).Value <> ws1.Cells(i, j).Value l = l + 1 Wend ws2.Cells(l, useColumn + count).Value = ws1.Cells(i, j).Value '重なった回数を入れる処理 m = 1 For l = useColumn + 1 To ws2.UsedRange.Columns.count ws2.Cells(2, l).Value = m m = m + 1 Next l 'Part1~Part3の作成 ws2.Range(Cells(1, useColumn + 1), Cells(1, ws2.UsedRange.Columns.count)).MergeCells = True With ws2.Cells(1, useColumn + 1) .Value = ws1.Cells(i, 1).Value .HorizontalAlignment = xlCenter End With Next j Next i '個数の表示 useRow = ws2.UsedRange.Rows.count ws2.Cells(useRow, 1).Value = "その個数" For i = 2 To ws2.UsedRange.Columns.count j = 3 While ws2.Cells(j, i).Value <> "" j = j + 1 Wend ws2.Cells(useRow + 1, i).Value = j - 3 & "個" Next i '枠の作成 With ws2.UsedRange .Borders(xlEdgeTop).Weight = xlThin .Borders(xlEdgeBottom).Weight = xlThin .Borders(xlEdgeLeft).Weight = xlThin .Borders(xlEdgeRight).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin .Borders(xlInsideVertical).Weight = xlThin End With End Sub
自分も同じデータを作っていたので、自分の方ではできるのにおかしいなと思っていました。
ソートして、「その個数」の位置を一つ下に直しました。
Option Explicit Sub Macro() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim LastRow As Long '最終行 Dim LastColumn As Integer '各行の最終列 Dim useColumn As Integer Dim useRow As Long '作業用変数 Dim i As Long Dim j As Integer Dim k As Integer Dim l As Integer Dim m As Integer Dim count As Integer Set ws1 = ActiveSheet 'データシート Set ws2 = Worksheets.Add '集計先シート ws2.Range("A2").Value = "重なった回数" ws2.Range("A3").Value = "その値" LastRow = ws1.Range("A" & Rows.count).End(xlUp).Row For i = 2 To LastRow useColumn = ws2.UsedRange.Columns.count LastColumn = ws1.Cells(i, Columns.count).End(xlToLeft).Column For j = 2 To LastColumn count = 0 For k = 2 To LastColumn If ws1.Cells(i, j).Value = ws1.Cells(i, k) Then count = count + 1 End If Next k l = 3 While ws2.Cells(l, useColumn + count) <> "" And _ ws2.Cells(l, useColumn + count).Value <> ws1.Cells(i, j).Value l = l + 1 Wend ws2.Cells(l, useColumn + count).Value = ws1.Cells(i, j).Value '重なった回数を入れる処理 m = 1 For l = useColumn + 1 To ws2.UsedRange.Columns.count ws2.Cells(2, l).Value = m m = m + 1 Next l 'Part1~Part3の作成 ws2.Range(Cells(1, useColumn + 1), Cells(1, ws2.UsedRange.Columns.count)).MergeCells = True With ws2.Cells(1, useColumn + 1) .Value = ws1.Cells(i, 1).Value .HorizontalAlignment = xlCenter End With Next j Next i '個数の表示 useRow = ws2.UsedRange.Rows.count ws2.Cells(useRow + 1, 1).Value = "その個数" For i = 2 To ws2.UsedRange.Columns.count ws2.Range(Cells(3, i), Cells(useRow, i)).Sort Key1:=ws2.Cells(3, i) j = 3 While ws2.Cells(j, i).Value <> "" j = j + 1 Wend ws2.Cells(useRow + 1, i).Value = j - 3 & "個" Next i '枠の作成 With ws2.UsedRange .Borders(xlEdgeTop).Weight = xlThin .Borders(xlEdgeBottom).Weight = xlThin .Borders(xlEdgeLeft).Weight = xlThin .Borders(xlEdgeRight).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin .Borders(xlInsideVertical).Weight = xlThin End With End Sub
無事実行できる事ができました。
これを期にVBAを勉強してみたいと思います。
ありがとうございました。
また質問することがあると思いますが宜しくお願いします。