| |
こんにちは。いつもお世話になっています。
人に頼まれ、星取表 (マトリクス) を作成するマクロを作成しています。
一応、手順としては、以下のような感じです。
完成イメージ
データ名 A B C
test ○ ○
tete ○
tst ○ ○
で、作業としては。
1. 星取の要素数分シートを用意する(この場合はA〜Cなので3)。
2. それぞれのシートのA列にデータ名を書き込む。
3. マクロを走らせると、星取り表が作成される。
というようなイメージで、作成したのが、下のマクロですが、
もう少しわかりやすいコードにならないかと言われてしまいまして、困ってます。
(ハッシュとかがわからないみたいです。)
仕様としては、特に作業手順等は決まってません。
(要はできるだけ簡単に星取り表が作成できたらいいだけです)
VBAでなく、一般機能でも結構ですので、何かいい方法はありますでしょうか?
御教授よろしくお願い致します。
Sub 星取表作成マクロ()
Dim d As Object
Dim w As Worksheet, nw As Worksheet
Dim i As Integer, j As Integer
Dim myItems As Variant, myKeys As Variant
Dim tmp As Variant
'ハッシュのために辞書を作成
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To Worksheets.Count: Set w = Worksheets(i) 'データの精査
With w
For j = 1 To .Range("A65536").End(xlUp).Row
If d.Exists(.Range("A" & j).Value) = False Then
d.Add .Range("A" & j).Value, i
Else
d.Item(.Range("A" & j).Value) = _
d.Item(.Range("A" & j).Value) & "," & i
End If
Next j
End With
Next i
'ここから書き出し
Set nw = Worksheets.Add(After:=Worksheets(Worksheets.Count)): nw.Name = "結果整理"
With nw
myKeys = d.keys
myItems = d.items
For i = LBound(myKeys) To UBound(myKeys)
.Range("A" & i + 1).Value = myKeys(i)
tmp = Split(myItems(i), ",")
If UBound(tmp) = 0 Then
.Cells(i + 1, tmp(0) + 1).Value = "○"
Else
For j = LBound(tmp) To UBound(tmp)
.Cells(i + 1, CInt(tmp(j)) + 1).Value = "○"
Next j
End If
Next i
End With
End Sub
|
|
ちくたく
- 06/7/13(木) 16:13 -
