Excel VBA質問箱 IV

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

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


12123 / 13645 ツリー ←次へ | 前へ→

【12241】データ抽出方法について dream 04/3/27(土) 22:51 質問
【12246】Re:データ抽出方法について Hirofumi 04/3/28(日) 2:37 回答
【12247】Re:データ抽出方法について dream 04/3/28(日) 3:30 質問
【12248】Re:データ抽出方法について Hirofumi 04/3/28(日) 7:21 回答
【12249】Re:データ抽出方法について dream 04/3/28(日) 9:17 お礼

【12241】データ抽出方法について
質問  dream  - 04/3/27(土) 22:51 -

引用なし
パスワード
   初心者で、悩んでいます。宜しくお願いします。

sheet1で
     A    B     C      D      E
  1   日付  商品   材料1   材料2   材料3
  2 2004/1/1 AA   1000      500     0
  3 2004/1/1 BB    0     1000     0
  4 2004/1/2 CC   500       0    500
  5 2004/1/3 CC   500      0    500
  6 2004/1/3 DD   500      500    1000  
 
のデータ(日付も、材料数も増え続けます)を、sheet2に各材料の数値が"0"以外のデータで、日別に集計して抽出したいのですが、どうすればよいでしょうか?
sheet2はこんな感じで予定しています。 
  
     A      B       C    D     E     F
  1   日付    材料1   日付    材料2   日付   材料3
  2 2004/1/1   1000   2004/1/1  1500   2004/1/2   500
  3 2004/1/2   500   2004/1/3   500   2004/1/3  1500
  4 2004/1/3   1000

のようにしたいのですが。

【12246】Re:データ抽出方法について
回答  Hirofumi E-MAIL  - 04/3/28(日) 2:37 -

引用なし
パスワード
   日付が昇順にソートされている事が前提として

以下を標準モジュールに記述して下さい

Option Explicit

Public Sub AddUp()

  '材料数 - 1
  Const lngKinds As Long = 2
  '材料1の列位置
  Const lngMat As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim vntData As Variant
  Dim lngEnd As Long
  Dim vntResult() As Variant
  Dim lngPos() As Long
  Dim lngCol As Long
  
  '結果用変数、書き込みポインッタを配列として確保
  ReDim vntResult((lngKinds + 1) * 2 - 1, 0), _
              lngPos(lngKinds)
  'Sheet1のデータを配列に取得
  With Worksheets("Sheet1")
    lngEnd = .Cells(65536, "A").End(xlUp).Row
    If lngEnd < 2 Then
      Beep
      MsgBox "データが有りません"
      Exit Sub
    End If
    vntData = Range(.Cells(1, "A"), _
            .Cells(lngEnd, "E")).Value
  End With
  '結果配列に列見出しを取得
  For i = 0 To lngKinds
    vntResult(i * 2, 0) = vntData(1, 1) '日付
    vntResult(i * 2 + 1, 0) _
          = vntData(1, i + lngMat) '材料
    lngPos(i) = 0 '書き込みポインッタの初期値
  Next i
  
  '集計
  'データの先頭から終りまで繰り返し
  For i = 2 To UBound(vntData, 1)
    '材料1、2、3に就いて繰り返し
    For j = 0 To lngKinds
      '書き込列を敬さん
      lngCol = j * 2
      'もし、日付が書き込み行の日付と違うなら
      If vntData(i, 1) _
        <> vntResult(lngCol, lngPos(j)) Then
        'もし、データが0を超えるなら
        If vntData(i, j + lngMat) > 0 Then
          '書き込み行を更新
          lngPos(j) = lngPos(j) + 1
          'もし、結果配列の大きさがより
          '書き込み位置が後なら
          If UBound(vntResult, 2) _
                  < lngPos(j) Then
            '結果配列を拡張
            ReDim Preserve _
              vntResult((lngKinds + 1) * 2 _
                      - 1, lngPos(j))
          End If
          '日付を代入
          vntResult(lngCol, lngPos(j)) _
                = vntData(i, 1)
          '値を代入
          vntResult(lngCol + 1, lngPos(j)) _
              = vntData(i, j + lngMat)
        End If
      Else
        '値を加算
        vntResult(lngCol + 1, lngPos(j)) _
            = vntResult(lngCol + 1, lngPos(j)) _
              + vntData(i, j + lngMat)
      End If
    Next j
  Next i
  
  '結果配列の行列を入れ替えて出力
  With Worksheets("Sheet2")
    .Cells(1, "A").Resize(UBound(vntResult, 2) + 1, _
          UBound(vntResult, 1) + 1).Value _
              = Application.Transpose(vntResult)
  End With
  
  Beep
  MsgBox "処理が完了しました"

End Sub

【12247】Re:データ抽出方法について
質問  dream  - 04/3/28(日) 3:30 -

引用なし
パスワード
   ありがとうございました。
早速確認しましたところ、日付データが増えていっても動作しましたが、材料数が増えていった場合、うまく抽出しませんでした。
コードも確認しながら、一部変更しながら試しましたが、初心者ですので、対応できませんでした。
恐れ入りますが、材料数が増えていった場合の対応の方法も、お願いします。

【12248】Re:データ抽出方法について
回答  Hirofumi E-MAIL  - 04/3/28(日) 7:21 -

引用なし
パスワード
   >早速確認しましたところ、日付データが増えていっても動作しましたが、
>材料数が増えていった場合、うまく抽出しませんでした。
ゴメン
>のデータ(日付も、材料数も増え続けます)
を忘れていました

最終列位置を自動で取得する様にしました
以下の様にコードを変更して下さい

Option Explicit

Public Sub AddUp()

  '材料1の列位置
  Const lngMat As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim vntData As Variant
  Dim lngEnd As Long
  Dim vntResult() As Variant
  Dim lngPos() As Long
  Dim lngCol As Long
  Dim lngKinds As Long '★この行追加
  
  'Sheet1のデータを配列に取得
  With Worksheets("Sheet1")
    '★以下の10行追加
    lngKinds = .Cells(1, _
          "IV").End(xlToLeft).Column
    If lngKinds < lngMat Then
      Beep
      MsgBox "データが有りません"
      Exit Sub
    End If
    lngKinds = lngKinds - lngMat
    '結果用変数、書き込みポインタを配列として確保
    ReDim vntResult((lngKinds + 1) * 2 - 1, 0)
    ReDim lngPos(lngKinds)
    lngEnd = .Cells(65536, "A").End(xlUp).Row
    If lngEnd < 2 Then
      Beep
      MsgBox "データが有りません"
      Exit Sub
    End If
    vntData = Range(.Cells(1, "A"), _
          .Cells(lngEnd, _
            lngMat + lngKinds)).Value
  End With
  '結果配列に列見出しを取得
  For i = 0 To lngKinds
    vntResult(i * 2, 0) = vntData(1, 1) '日付
    vntResult(i * 2 + 1, 0) _
          = vntData(1, i + lngMat) '材料
    lngPos(i) = 0 '書き込みポインタの初期値
  Next i
  
  '集計
  'データの先頭から終りまで繰り返し
  For i = 2 To UBound(vntData, 1)
    '材料1、2、3に就いて繰り返し
    For j = 0 To lngKinds
      '書き込み列を計算
      lngCol = j * 2
      'もし、日付が書き込み行の日付と違うなら
      If vntData(i, 1) _
        <> vntResult(lngCol, lngPos(j)) Then
        'もし、データが0を超えるなら
        If vntData(i, j + lngMat) > 0 Then
          '書き込み行ポインタを更新
          lngPos(j) = lngPos(j) + 1
          'もし、結果配列の大きさがより
          '書き込み位置が後なら
          If UBound(vntResult, 2) _
                  < lngPos(j) Then
            '結果配列を拡張
            ReDim Preserve _
              vntResult((lngKinds + 1) * 2 _
                      - 1, lngPos(j))
          End If
          '日付を代入
          vntResult(lngCol, lngPos(j)) _
                = vntData(i, 1)
          '値を代入
          vntResult(lngCol + 1, lngPos(j)) _
              = vntData(i, j + lngMat)
        End If
      Else
        '値を加算
        vntResult(lngCol + 1, lngPos(j)) _
            = vntResult(lngCol + 1, lngPos(j)) _
              + vntData(i, j + lngMat)
      End If
    Next j
  Next i
  
  '結果配列の行列を入れ替えて出力
  With Worksheets("Sheet2")
    .Cells(1, "A").Resize(UBound(vntResult, 2) + 1, _
          UBound(vntResult, 1) + 1).Value _
              = Application.Transpose(vntResult)
  End With
  
  Beep
  MsgBox "処理が完了しました"

End Sub

【12249】Re:データ抽出方法について
お礼  dream  - 04/3/28(日) 9:17 -

引用なし
パスワード
   私の想っている通りの動作ができました。
hirohumiさんは、すごいですね!
私は初心者ですので、コードの内容がほとんど理解できておりません。

私も、思った通りのコードが書ける様にがんばって勉強して行こうと思います。
今回は本当に有り難うございました。

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