人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

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

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

1214816927
●拡大する

●質問者: HLYGRL
●カテゴリ:コンピュータ インターネット
✍キーワード:URL VBA エクセル コメント ソート
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● SALINGER
●250ポイント

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

データ行は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

2 ● SALINGER
●250ポイント

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

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

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を勉強してみたいと思います。

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ