Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


41382 / 76732 ←次へ | 前へ→

【40430】星取表を作成するマクロ
質問  ちくたく  - 06/7/13(木) 16:13 -

引用なし
パスワード
   こんにちは。いつもお世話になっています。

人に頼まれ、星取表 (マトリクス) を作成するマクロを作成しています。
一応、手順としては、以下のような感じです。

完成イメージ

データ名 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
0 hits

【40430】星取表を作成するマクロ ちくたく 06/7/13(木) 16:13 質問
【40437】Re:星取表を作成するマクロ ハト 06/7/13(木) 17:48 発言
【40444】Re:星取表を作成するマクロ ichinose 06/7/13(木) 20:53 発言
【40475】Re:星取表を作成するマクロ ちくたく 06/7/14(金) 14:05 お礼

41382 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free