Excel VBA質問箱 IV

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

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


7220 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【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

【40437】Re:星取表を作成するマクロ
発言  ハト  - 06/7/13(木) 17:48 -

引用なし
パスワード
   ▼ちくたく さん:
>こんにちは。いつもお世話になっています。
>
>人に頼まれ、星取表 (マトリクス) を作成するマクロを作成しています。
>一応、手順としては、以下のような感じです。
>
>完成イメージ
>
>データ名 A B C
>test   ○ ○
>tete    ○
>tst     ○ ○
>
>で、作業としては。
>
>1. 星取の要素数分シートを用意する(この場合はA〜Cなので3)。
>2. それぞれのシートのA列にデータ名を書き込む。
>3. マクロを走らせると、星取り表が作成される。
>
>というようなイメージで、作成したのが、下のマクロですが、
>もう少しわかりやすいコードにならないかと言われてしまいまして、困ってます。
>(ハッシュとかがわからないみたいです。)
>
>仕様としては、特に作業手順等は決まってません。
>(要はできるだけ簡単に星取り表が作成できたらいいだけです)
>VBAでなく、一般機能でも結構ですので、何かいい方法はありますでしょうか?
>御教授よろしくお願い致します。

わかりやすいコード・・・
プログラムの事をよくわからない方に理解しやすいコードと考えると
手作業で行う事をコード化していくということですかね?

ちくたくさんのに比べると稚拙ですが
とりあえず↓のようなのを考えてみました


Sub 星取表作成マクロ_劣化版()

  Dim w As Worksheet, nw As Worksheet
  Dim i As Integer, j As Integer
  Dim NData As Range
  Dim k As Long
  
  Application.ScreenUpdating = False
    
  '書き出しシート
  Set nw = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  nw.Name = "結果整理"
 
  '星取りシート毎に処理
  For i = 1 To Worksheets.Count - 1
    Set w = Worksheets(i)  'データの精査
    With w
      'シート名を記入
      nw.Cells(1, i + 1).Value = w.Name
      '各データ名毎に処理
      For j = 1 To .Range("A65536").End(xlUp).Row
        '書き出しシートにデータ名があるかチェック
        Set NData = nw.Range("A:A").Find(.Cells(j, 1).Value, , , xlWhole, , , False, False)
        
        If NData Is Nothing Then
          '書き出しシートにデータ名なし
          'データ名を書き出しシートに追加
          k = nw.Range("A65536").End(xlUp).Row + 1
          nw.Cells(k, 1).Value = .Cells(j, 1).Value
          nw.Cells(k, i + 1).Value = "○"
        Else
          '書き出しシートにデータ名あり
          nw.Cells(NData.Row, i + 1).Value = "○"
        End If
        
      Next j
    End With
  Next i
   
  Application.ScreenUpdating = True
   
End Sub

【40444】Re:星取表を作成するマクロ
発言  ichinose  - 06/7/13(木) 20:53 -

引用なし
パスワード
   こんばんは。

>もう少しわかりやすいコードにならないかと言われてしまいまして、困ってます。
>(ハッシュとかがわからないみたいです。)
Dictionaryをハッシュと呼ぶのは私は抵抗がありますが・・・。
まあそれはさておき、
これの仕組みは簡単ですよね!!
私は、このサイトの投稿でしか使ったことがありませんが、
そもそもプロパティやメソッドも少ないし・・・。
わかりやすいオブジェクトです。

わからなかったら覚えなさい!!
というのが本当は結論のような気がしますけどねえ

これをDictionaryを使わないでとなると・・・。

Dictionaryと同じような処理コードを書かなくてはなりませんよね!!


このデータってアルファベットだけなんですか?
「漢字」とか「カタカナ」とか「ひらがな」はないのですか?

これと同じ処理にしようとすると、Match関数が使えないですね?
(Match比較がテキスト比較だから・・・)


標準モジュールに
'==================================================================
Sub main()
  Dim w As Worksheet, nw As Worksheet
  Dim i As Integer
  Call open_tbl(Worksheets.Count + 1)
  For i = 1 To Worksheets.Count
    With Worksheets(i)
      For Each crng In .Range("a1", .Cells(.Rows.Count, "a").End(xlUp))
        Call put_tbl(crng.Value, i + 1, "○")
        Next
      
      End With
    Next i
  Set nw = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  With nw
   .Name = "結果整理"
   .Range("a1", .Cells(get_tblcnt, Worksheets.Count)).Value = Application.Transpose(get_tbl())
   End With
  Call close_tbl
End Sub


別の標準モジュールに
'Dictionaryオブジェクトの代わりのコード
'=================================================================
Private myarray() As Variant
Private colnum As Long
Private fptr As Long
'=================================================================
sub open_tbl(列数 As Long)
'テーブルi/oを初期化する IN:テーブル列の数(キー列も含む)
  ReDim myarray(1 To 列数, 1 To 1)
  colnum = 列数
  fptr = 1
End sub
'=================================================================
Sub close_tbl()
'テーブルi/oの終了処理
  Erase myarray()
  colnum = 0
  fptr=0
End Sub
'=================================================================
Sub put_tbl(key As Variant, colidx As Long, myvalue As Variant)
'テーブルにデータをセットする
' in key 検索キーデータ colidx--myvalueをセットする列数 myvalue--セットするデータ
  Dim idx As Long
  Dim f_flg As Long '0:keyで検索の結果見つからない 1:見つかった
  f_flg = 0
  For idx = 1 To fptr - 1
    If myarray(1, idx) = key Then
     GoSub put_proc
     f_flg = 1
     Exit For
     End If
    Next idx
  If f_flg = 0 Then
    ReDim Preserve myarray(1 To colnum, 1 To fptr)
    idx = fptr
    myarray(1, idx) = key
    fptr = fptr + 1
    GoSub put_proc
    End If
  Exit Sub
put_proc: 'in--idx colidx myvalue out:myarray()
  myarray(colidx, idx) = myvalue
  Return
End Sub
'=================================================================
Function get_tbl() As Variant
'テーブルを取得する
  get_tbl = myarray()
End Function
'=================================================================
Function get_tblcnt() As Long
'テーブル要素数を取得する
  get_tblcnt = UBound(myarray(), 2)
End Function


でmainを実行してみてください。

Dictionaryの有用性を解いたほうがよいと思いますが・・・。

【40475】Re:星取表を作成するマクロ
お礼  ちくたく  - 06/7/14(金) 14:05 -

引用なし
パスワード
   ハトさん、ichinoseさん

レスありがとうございました。
ちょっと、出先でばたついておりますので、取り急ぎお礼を。

>ハトさん
御教授、ありがとうございます。
Findを使った方がわかりやすいかもしれないですね。
ちょっと、気になるのが実行速度ですが、
「難しくてわからない」と言うくらいなら、我慢してもらいます(微笑)

>ichinoseさん
すいません、perlが根っこなもので、ハッシュって言ってしまいがちなんですよ。
Dictionryの機能を書いて説明して頂いた感じで、個人的にはありがたいです。
しかし、逆説的ですが、このコードを見ると、ご自身が仰られているように、
dictionaryを使ったほうが良いかも。
せっかくそういうオブジェクトが用意されているのですからねぇ。
Dictionaryとか、正規表現みたいな、
VBAに実装されていない(<-言葉が悪いですが)ものは苦手みたいですね。

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