Excel VBA質問箱 IV

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

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


63527 / 76732 ←次へ | 前へ→

【17800】Re:表の整理
回答  ichinose  - 04/9/8(水) 7:38 -

引用なし
パスワード
   ▼よしまん さん:
おはようございます。

>VBAをなんとか理解できるが、自分で記述するまではまだ力がたりない初心者で、もし以下のことをVBAで自動化できないものかと思っておりまして、アドバイスいただけると幸いです。エクセル2002を使っています。
>
>やりたいことは以下の2点です。
>
>1.以下のような表があります。
>
>  No | 氏名 |8/1| 〜 |8/31|←列見出し
>  −−−−−−−−−−−−−−−−−−−−−−−
>  154| 山田 | 1  | 〜 | 1  |
>  187| 横山 | 1  | 〜 |    |

上記の表があるシートをSheet1とし、項目名NoがセルA1から始まっているとします。


>この表は各個人(約300名)の毎月のある実績について、実績があればその該当日(列見出し)のセルに「1」を入力して、各個人の実績を列方向に管理を行っており、月ごとに私がその提出を受けているものです。
>
>この表でまず、「1」を実際の日付に置き換えたいのです。1行ごとに行を挿入し、if関数をつかい、数式をコピーして、あとで行を削除するなどとできないことはないのですが、手作業ということで、ミスが発生しやすくなるため、VBAで自動化できないものだろうかというのが1つめの質問です。
>
>2.なぜ1のようにしたいのかといいますと。1で整理した表を最終的に以下のような表に整理して、アクセスにインポートしたいからなのです。整理したいという表は
>
> 個人氏名 | 日付  | ←列見出し
> −−−−−−−−−−−−−−−−−−
>  山田 |8/1  |
>  山田 |8/31 |
>  横山 |8/1  |
>  横山 |8/25 |

上記の表があるシートをSheet2とし、項目名、個人氏名がセルA1から始まっているとします。

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で確認しました。
1 hits

【17790】表の整理 よしまん 04/9/7(火) 20:29 質問
【17800】Re:表の整理 ichinose 04/9/8(水) 7:38 回答
【17857】Re:表の整理 よしまん 04/9/8(水) 20:54 お礼

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