Excel VBA質問箱 IV

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

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


6910 / 13646 ツリー ←次へ | 前へ→

【42392】月別集計をしたい taku 06/9/9(土) 7:41 質問[未読]
【42396】Re:月別集計をしたい かみちゃん 06/9/9(土) 8:55 発言[未読]
【42397】Re:月別集計をしたい Hirofumi 06/9/9(土) 9:08 回答[未読]
【42398】Re:月別集計をしたい Hirofumi 06/9/9(土) 9:19 回答[未読]
【42410】Re:月別集計をしたい ichinose 06/9/9(土) 21:29 発言[未読]

【42392】月別集計をしたい
質問  taku  - 06/9/9(土) 7:41 -

引用なし
パスワード
   日付    品名   金額
2005/1/12 パソコン 120,000
2005/1/23 プリンタ  50,000
2005/2/15 パソコン 200,000
2005/2/25 プリンタ  35,000

のようなデータを品名別、VBAで月別に集計したいのですが
よくわからないので教えてもらえませんか。

【42396】Re:月別集計をしたい
発言  かみちゃん  - 06/9/9(土) 8:55 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>日付    品名   金額
>2005/1/12 パソコン 120,000
>2005/1/23 プリンタ  50,000
>2005/2/15 パソコン 200,000
>2005/2/25 プリンタ  35,000
>
>のようなデータを品名別、VBAで月別に集計したいのですが

簡単な方法としては、一般操作の「ピボットテーブル」でできます。
以下を参考にしてみてください。
http://www11.plala.or.jp/koma_Excel/contents3/mame3031/mame303101.html

なお、月別とは、日付欄は、年は、同じ年ばかりですか?
たとえば、上記の例で、2006/1/xxというようなデータはないのですか?
ある場合は、2005/1と2006/1は、別々の月として集計したいのでしょうか?
つまり、月別なのか年月別なのかによって、コードの作り方は変わります。

あと、月別の表は、あらかじめ用意されているのですか?
たとえば、上記の例で、2005/3/xxのデータがない場合は、
1月、2月、4月という結果にしていいのか、3月は空白としたいのか・・・

とりあえず、期待している結果のシートイメージも提示できませんか?

【42397】Re:月別集計をしたい
回答  Hirofumi  - 06/9/9(土) 9:08 -

引用なし
パスワード
   列の挿入、1つづつのセルへのアクセスを行うので速い処理では有りませんが
尚、データListはSheet1のA1から有る物とし、結果はSheet2のA1を先頭として出力します
また、結果の月は、月初(例えば、2005/1/1)のシリアル値が入る物とします

Option Explicit

Public Sub CrossTabulation()

  'データ列数(A列〜C列)
  Const clngColumns As Long = 3
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim rngDate As Range
  Dim rngScope As Range
  Dim lngColumn As Long
  Dim lngRow As Long
  Dim vntMonth As Variant
  Dim strProm As String
  
  'データListの左上隅セル位置を基準として設定(列見出しの「日付」セル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Offset(1).Resize(lngRows + 1, clngColumns).Value
  End With
  
  '結果出力シートのA1セルを基準とする(Listの左上隅)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngColumn = .Offset(, Columns.Count - _
              .Column).End(xlToLeft).Column - .Column
    '日付列の範囲を取得
    If lngColumn > 0 Then
      Set rngDate = .Offset(, 1).Resize(, lngColumn)
    End If
    '品名が有る行数を取得
    lngRow = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    '品名が有る範囲を取得
    If lngRow > 0 Then
      Set rngScope = .Offset(1).Resize(lngRow)
    End If
  End With

  '画面更新を停止
  Application.ScreenUpdating = False
  
  'データの最終行まで繰り返し
  For i = 1 To lngRows
      '日付のシリアル値から月初の値を取得
      vntMonth = DateSerial(Year(vntData(i, 1)), Month(vntData(i, 1)), 1)
      '日付を探索
      lngColumn = GetColumnPos(vntMonth, rngDate, rngResult)
      '品名を探索
      lngRow = GetRowPos(vntData(i, 2), rngScope, rngResult)
      '日付、品名の交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngColumn)
        .NumberFormatLocal = "#,##0;""▲ ""#,##0"
        .Value = .Value + vntData(i, 3)
      End With
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  Set rngScope = Nothing
  Set rngDate = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetColumnPos(vntDate As Variant, _
                rngScope As Range, _
                rngDateTop As Range) As Long

  Dim lngFound As Long
  Dim lngOver As Long
  Dim lngCount As Long

  '日付範囲に日付が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
    lngOver = 1
  Else
    '日付の探索
    'セル値が数値として入力されている場合
    lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
    'セル値が文字列として入力されている場合
'    lngFound = DataSearch(vntDate, rngScope, lngOver)
    lngCount = rngScope.Columns.Count
  End If

  '日付が見つかった場合
  If lngFound > 0 Then
    '位置を返す
    GetColumnPos = lngFound
  Else
    With rngDateTop
      '日付が最終列の以内の場合
      If lngOver <= lngCount Then
        '指定位置に列を挿入
        .Offset(, lngOver).EntireColumn.Insert
      End If
      '日付を書き込み
      With .Offset(, lngOver)
        .NumberFormatLocal = "yyyy/m"
'        .NumberFormatLocal = "m""月"""
        .Value = vntDate
      End With
      '挿入位置を返す
      GetColumnPos = lngOver
      '日付列の範囲を更新
      Set rngScope = .Offset(, 1).Resize(, lngCount + 1)
    End With
  End If

End Function

Private Function GetRowPos(vntKey As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Long
  Dim lngCount As Long

  '品名範囲に品名が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
  Else
    '品名を探索
    lngFound = DataSearch(vntKey, rngScope, , 0)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(品名が有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetRowPos = lngFound
  Else
    With rngListTop
      '行末位置を更新
      lngCount = lngCount + 1
      'セルの書式を文字列に設定
      '(001の様な場合無いと探索が出来ない)
      .Offset(lngCount).NumberFormatLocal = "@"
      '行末に品名を書き込み
      .Offset(lngCount).Value = vntKey
      '挿入位置を返す
      GetRowPos = lngCount
      '探索範囲の更新
      Set rngScope = .Offset(1).Resize(lngCount)
    End With
  End If

End Function

Private Function DataSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngMode As Long = 1) As Long

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngMode)
  lngOver = 1
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      DataSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  End If

End Function

【42398】Re:月別集計をしたい
回答  Hirofumi  - 06/9/9(土) 9:19 -

引用なし
パスワード
   書き忘れましたが
月と品名は、勝手に書き込んで行きます
試すなら、先ずは其のままで実行して下さい

【42410】Re:月別集計をしたい
発言  ichinose  - 06/9/9(土) 21:29 -

引用なし
パスワード
   ▼taku さん:
こんばんは。
SQLで行ったクロス集計です。

以下のデータが
Sheet1というシートのセルA1から
設定されているという条件です。
(1行目は項目名です)

>日付    品名   金額
>2005/1/12 パソコン 120,000
>2005/1/23 プリンタ  50,000
>2005/2/15 パソコン 200,000
>2005/2/25 プリンタ  35,000

集計結果は、同じブックのSheet2というシート名に書き込みます。


標準モジュールに
'================================
Sub test()
  Dim idx As Long
  Dim rs As Object
  Dim mysql As String
  If open_ado_excel(ThisWorkbook.FullName) = 0 Then
    mysql = "Transform sum(金額) " & _
        "Select 品名 From [Sheet1$] Group By 品名 " & _
        "Pivot year(日付)*100+month(日付);"
    If get_exec_sql(mysql, rs) = 0 Then
     With Worksheets("Sheet2")
      .Cells.ClearContents
      .Range("a2").CopyFromRecordset rs
      For idx = 0 To rs.fields.Count - 1
       .Cells(1, idx + 1).Value = "'" & Format(rs.fields(idx).Name, "0000年00月")
       Next
      End With
     Call rs_close(rs)
    Else
     MsgBox "rs error"
     End If
    Call close_ado
  Else
    MsgBox "cn error"
    End If
End Sub


別の標準モジュールに
'==================================================================
Public cn As Object
'=========================================================
Function open_ado_excel(book_fullname As String) As Long
  On Error Resume Next
  Dim link_opt As String
  link_opt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
       "Data Source=" & book_fullname & ";" & _
       "Extended Properties=Excel 8.0;"
  Set cn = CreateObject("ADODB.Connection")
  cn.Open link_opt
  open_ado_excel = Err.Number
  On Error GoTo 0
End Function
'=========================================================
Sub close_ado()
  On Error Resume Next
  cn.Close
  Set cn = Nothing
  On Error GoTo 0
End Sub
'=========================================================
Function get_exec_sql(sql_str, rs As Object) As Long
  On Error Resume Next
  Set rs = cn.Execute(sql_str)
  get_exec_sql = Err.Number
  On Error GoTo 0
End Function
'=========================================================
Sub rs_close(rs As Object)
  On Error Resume Next
  rs.Close
  Set rs = Nothing
  On Error GoTo 0
End Sub


として、一度適当なブック名で保存した後に
testを実行してみてください。

以前投稿したコードをほんのちょっと手直ししただけです。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=28380;id=excel

(SQLと後始末のコードだけ変更しました)


ブックを開いたまま、繰り返し実行するには問題もありますが、
(その場合はデータブックとVBAコードを含むブックを分けなければなりません)

ブックを開いて一度集計するくらいなら、問題ないと思います。

試してみてください。

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