1214816927 エクセル(Excel2003)のマクロ作成お願いします。

それぞれの行ごとに、同じ数値が重なった回数ごとに値をソートして並べるものです。
また、その個数も付けてください。
下の画像のような感じです。
http://f.hatena.ne.jp/HLYGRL/20080630175522

VBA初心者なので各マクロの説明などもよろしくお願いします。

#また、文字制限のため、サンプルデータと作っていただきたいもののサンプル例(上記URLと同じ)を
この下にある「この質問・回答へのコメント」に記載します。

回答の条件
  • 1人5回まで
  • 登録:
  • 終了:2008/06/30 23:17:54
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

回答2件)

id:SALINGER No.1

回答回数3454ベストアンサー獲得回数969

ポイント250pt

データ元の表が左上詰めで作成されているとして、新規シートを作ってそこに図と同じ集計表を作るマクロです。

データ行は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
id:SALINGER No.2

回答回数3454ベストアンサー獲得回数969

ポイント250pt

自分も同じデータを作っていたので、自分の方ではできるのにおかしいなと思っていました。

ソートして、「その個数」の位置を一つ下に直しました。

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
id:HLYGRL

無事実行できる事ができました。

これを期にVBAを勉強してみたいと思います。

ありがとうございました。

また質問することがあると思いますが宜しくお願いします。

2008/06/30 23:16:48
  • id:HLYGRL
    ・元のデータ(実際はもっとたくさんのデータがあります。Number100ぐらいまで。)

    Number 1 2 3 4 5 6 7 8 9 10 11 12
    Part1 1.31 1.23 1.21 1.31 1.22 1.21 1.31 1.22 1.23 1.11 1.12 1.13
    Part2 2.31 2.23 2.21 2.31 2.22 2.21 2.31 2.22 2.23 2.11 2.12
    Part3 3.31 3.11 3.21 3.31 3.22 3.21 3.31 3.22 3.12 3.13


    ・マクロで作っていただきたいもの

    Part1 Part2 Part3
    重なった回数 1 2 3 4 1 2 3 4 1 2 3 4
    その値 1.11 1.21 1.31 2.11 2.21 2.31 3.11 3.21 3.31
    1.12 1.22 2.12 2.22 3.12 3.22
    1.13 1.23 2.23 3.13
    その個数 3個 3個 1個 0個 2個 3個 1個 0個 3個 2個 1個 0個

    よろしくお願いします。
  • id:SALINGER
    私の回答の4行目と5行目の

    Dim h1() As Double
    Dim h2() As Integer

    は使わなかったので削除してください。
  • id:taknt
    5つ以上、重なるということは ないんですね?
  • id:HLYGRL
    SALINGERさん
    マクロ作成ありがとうございます。
    下記url画像のように一部の列で数字が2回でてしまって、回数も間違ってしまうようです。
    できれば訂正おねがいできますか?
    あと、大きさ順にソートもお願いします。
    http://f.hatena.ne.jp/HLYGRL/20080630211557
  • id:HLYGRL
    takntさん
    少ないとは思いますが5つ以上重なることもあります。
  • id:HLYGRL
    SALINGERさん
    さきほど、違うデータで試してみたところ無事重複なく実行することができました。
    http://f.hatena.ne.jp/HLYGRL/20080630215333

    ありがとうございます。
  • id:SALINGER
    むやみと変数を使っていてわかりずらいコードになってしまって申し訳ありませんでした。

    Excelを使ったゲームを企画しているので、仕事の息抜きにでもどうぞ。
    http://q.hatena.ne.jp/1214797405

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません