| |
▼よしまん さん：
おはようございます。
>ＶＢＡをなんとか理解できるが、自分で記述するまではまだ力がたりない初心者で、もし以下のことをＶＢＡで自動化できないものかと思っておりまして、アドバイスいただけると幸いです。エクセル２００２を使っています。
>
>やりたいことは以下の２点です。
>
>１．以下のような表があります。
>
> Ｎｏ ｜ 氏名 ｜８／１｜ 〜 ｜８／３１｜←列見出し
> −−−−−−−−−−−−−−−−−−−−−−−
> １５４｜ 山田 ｜ １ ｜ 〜 ｜ １ ｜
> １８７｜ 横山 ｜ １ ｜ 〜 ｜ ｜
上記の表があるシートをSheet1とし、項目名ＮｏがセルＡ１から始まっているとします。
>この表は各個人（約３００名）の毎月のある実績について、実績があればその該当日（列見出し）のセルに｢１｣を入力して、各個人の実績を列方向に管理を行っており、月ごとに私がその提出を受けているものです。
>
>この表でまず、「１」を実際の日付に置き換えたいのです。１行ごとに行を挿入し、ｉｆ関数をつかい、数式をコピーして、あとで行を削除するなどとできないことはないのですが、手作業ということで、ミスが発生しやすくなるため、ＶＢＡで自動化できないものだろうかというのが１つめの質問です。
>
>２．なぜ１のようにしたいのかといいますと。１で整理した表を最終的に以下のような表に整理して、アクセスにインポートしたいからなのです。整理したいという表は
>
> 個人氏名 ｜ 日付 ｜ ←列見出し
> −−−−−−−−−−−−−−−−−−
> 山田 ｜８／１ ｜
> 山田 ｜８／３１ ｜
> 横山 ｜８／１ ｜
> 横山 ｜８／２５ ｜
上記の表があるシートをSheet2とし、項目名、個人氏名がセルＡ１から始まっているとします。
Sheet1の表から、Sheet2の表が作成する事が目的ですね？
（つまり、Sheet1の表中の「1」を日付けに変換する処理は過程処理で
要りませんよね？）
以下に示すマクロを実行する前に、
・Sheet1の形式でサンプルデータの準備
・Sheet2の形式の項目名のみ作成
・Sheet2の表の日付けセルの書式を"m/d"にしておく
等を行っておいてください。
では、コードです。
'=====================================================================
Sub main()
Dim d_cell As Range
Dim rng As Range
Dim sht2 As Worksheet
Dim wk() As Variant
Dim ans() As String
Dim shx As Long, idx As Long
With Worksheets("sheet1")
Set rng = .Range("a2", .Cells(.Rows.Count, 1).End(xlUp))
If rng.Row <= 1 Then
MsgBox "データ無し"
End
End If
Set d_cell = .Range(.Cells(1, 3), .Cells(1, .Columns.Count).End(xlToLeft))
'↑項目の日付セル範囲を取得
End With
Set sht2 = Worksheets("sheet2")
shx = 2
For idx = 1 To rng.Count 'Sheet1のデータ分繰り返す
Erase wk()
Erase ans()
ad = rng.Cells(idx).Offset(0, 2).Resize(1, d_cell.Count).Address(, , , True)
wk() = Evaluate("=if(" & ad & "=1,text(" & d_cell.Address(, , , True) _
& ",""m/d""),""×"")")
ans() = Filter(wk(), "×", False, vbTextCompare)
'↑ 1のセルを取得し、日付に置き換えた配列を取得する
If UBound(ans()) - LBound(ans()) + 1 > 0 Then '日付けデータがあったら？
sht2.Range(sht2.Cells(shx, 1), _
sht2.Cells(shx + UBound(ans()) - LBound(ans()), 1)).Value = _
rng.Cells(idx, 2).Value
'↑名前をセット
sht2.Range(sht2.Cells(shx, 2), _
sht2.Cells(shx + UBound(ans()) - LBound(ans()), 2)).Value = _
Application.Transpose(ans())
'日付けをセット
shx = shx + UBound(ans()) - LBound(ans()) + 1
'Sheet2の行インデックスの更新
End If
Next idx
Erase wk()
Erase ans()
End Sub
Excel2000で確認しました。
|
|
ichinose
- 04/9/8(水) 7:38 -
