Excel VBA質問箱 IV

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

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


41375 / 76732 ←次へ | 前へ→

【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
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 お礼

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