| |
▼ちくたく さん：
>こんにちは。いつもお世話になっています。
>
>人に頼まれ、星取表 (マトリクス) を作成するマクロを作成しています。
>一応、手順としては、以下のような感じです。
>
>完成イメージ
>
>データ名 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
|
|
ハト
- 06/7/13(木) 17:48 -
