Excel VBA質問箱 IV

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

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


22160 / 76734 ←次へ | 前へ→

【59959】Re:年間月別合計の出し方
発言  kanabun  - 09/1/20(火) 23:31 -

引用なし
パスワード
   ▼ひかる さん:

習慣のため、寝付けないので、ちょっと年号情報を加味してみました。
集計元の A列データは 2008/4/15 のような値が入っていて、
(表示形式 m"月"d"日" )
集計先の 1行目には 2008/4 〜 2009/3 のような日付データが
(表示形式 「m"月"」で 入力されているものとします)

Sub Try4() '集計先のシートをアクティブにして実行
  Dim WS1 As Worksheet
  Dim WS2 As Worksheet
  Dim dic As Object
  Dim r As Range, c As Range
  Dim tbl
  Dim i As Long, ss As String
  Dim strRoom As String
  Dim strSecond As String
  
  Set WS1 = Worksheets("◆Sheet1") '抽出元の表のあるシート
  Set WS2 = ActiveSheet      'アクティブシート(集計表)
  Set r = WS2.Range("A1").CurrentRegion '書きこみ先表範囲
  Set r = Intersect(r, r.Offset(1, 2)) 'そのうち、正味データ部
    r.Select
    MsgBox "この範囲が正味データ範囲"
  
  r.ClearContents  '行列見出しを除く正味データ部をクリア
  tbl = r.Value   'クリア後の範囲を配列に格納
  
  '---- 書き出し先のテーブル情報をDictionaryに格納 -----
  Set dic = CreateObject("Scripting.Dictionary")
  '行列見出し位置を辞書に格納
  For Each c In r.Resize(, 1).Offset(, -1) 'A+B列見出し項目(室+大小)
    i = i + 1
    If Len(c(1, 0).Text) Then strRoom = c(1, 0).Text
    dic(strRoom & c.Text) = i
  Next
  i = 0
  For Each c In r.Resize(1).Offset(-1) '1行目見出し項目(◆年月)
    ss = Format$(c.Value, "yyyy/mm")
    i = i + 1
    dic(ss) = i
  Next
  strSecond = WS2.[B2].Value '第2 項目(見出し)のサンプル
  
  '---- 元表のA列×1行目の見出しに対応する 書きこみ先の _
    配列tblの 行列番号を Dictionaryから得る  -----
  Dim rr As Range
  Dim MonData, RoomData, dat
  Dim SecondData 'B列またはC列格納用変数
  Dim j As Long, n As Long, m As Long, x As Long
  With WS1
    .Activate      '◆デバッグ用追加
    Set rr = .Range("A1").CurrentRegion '.Resize(, 5)
    rr.Select      '←↓◆◆デバッグ用追加
    If MsgBox("この範囲が元データ範囲 " & _
      rr.Address(0, 0), vbOKCancel) = vbCancel Then Exit Sub
  End With
  
  Set rr = Intersect(rr, rr.Offset(1, 3)) '◆列方向 D列から 「室」見出し
  rr.Select        '←↓◆◆デバッグ用追加
  MsgBox "この範囲が正味数値データ範囲 " & rr.Address(0, 0)
  MonData = rr.Offset(, -3).Resize(, 1).Value
  Set c = rr.Offset(, -2).Resize(, 2)
  Set c = c.Find(strSecond, , xlValues, xlWhole)
  If c Is Nothing Then
    MsgBox "第2項目の列取得に失敗しました" & vbCr _
       & " 元データシートの B,C列に <" & strSecond & _
       "> が見つかりませんでした"
    Exit Sub
  End If
  MsgBox WS1.Cells(1, c.Column).Value & " の列を集計に使います"
  Select Case c.Column
   Case 2: x = -2
   Case 3: x = -1
  End Select
  SecondData = rr.Offset(, x).Resize(, 1).Value
  RoomData = rr.Resize(1).Offset(-1).Value
  For i = 1 To UBound(MonData, 1) '日付のレコード順に
    dat = MonData(i, 1)
    If IsDate(dat) Then
      ss = Format$(dat, "yyyy/mm")
      If dic.Exists(ss) Then
        m = dic(ss) '何列目か
        For j = 1 To UBound(RoomData, 2)
          ss = RoomData(1, j) & SecondData(i, 1)
          If dic.Exists(ss) Then
            n = dic(ss) '何行目か
            '------tblのn行,m列目の要素に 数量を累加 -----
            tbl(n, m) = tbl(n, m) + rr(i, j).Value
          End If
        Next
      End If
    End If
  Next
  
  '---- 配列に集計した結果を表に書き出す ------
  r.Value = tbl
  WS2.Activate
  MsgBox "集計が終わりました"
End Sub

5 hits

【59849】年間月別合計の出し方 ひかる 09/1/13(火) 20:39 質問
【59850】Re:年間月別合計の出し方 kanabun 09/1/13(火) 21:18 発言
【59855】Re:年間月別合計の出し方 ひかる 09/1/13(火) 22:47 質問
【59856】Re:年間月別合計の出し方 kanabun 09/1/14(水) 0:09 発言
【59857】Re:年間月別合計の出し方 kanabun 09/1/14(水) 0:15 発言
【59858】Re:年間月別合計の出し方 ひかる 09/1/14(水) 7:07 お礼
【59859】Re:年間月別合計の出し方 kanabun 09/1/14(水) 9:33 発言
【59886】Re:年間月別合計の出し方 ひかる 09/1/15(木) 16:07 質問
【59887】Re:年間月別合計の出し方 ひかる 09/1/15(木) 16:21 お礼
【59892】Re:年間月別合計の出し方 kanabun 09/1/15(木) 16:51 発言
【59949】Re:年間月別合計の出し方 ひかる 09/1/20(火) 18:29 質問
【59950】Re:年間月別合計の出し方 kanabun 09/1/20(火) 20:25 発言
【59954】Re:年間月別合計の出し方 ひかる 09/1/20(火) 21:35 質問
【59955】Re:年間月別合計の出し方 kanabun 09/1/20(火) 21:49 発言
【59956】Re:年間月別合計の出し方 ひかる 09/1/20(火) 22:09 質問
【59957】Re:年間月別合計の出し方 kanabun 09/1/20(火) 22:50 発言
【59958】Re:年間月別合計の出し方 kanabun 09/1/20(火) 23:04 発言
【59959】Re:年間月別合計の出し方 kanabun 09/1/20(火) 23:31 発言
【59960】Re:年間月別合計の出し方 ひかる 09/1/20(火) 23:42 お礼
【59981】Re:年間月別合計の出し方 ひかる 09/1/22(木) 12:02 お礼
【59983】Re:年間月別合計の出し方 ひかる 09/1/22(木) 12:52 質問
【59988】Re:年間月別合計の出し方 ひかる 09/1/22(木) 18:07 質問
【60025】Re:年間月別合計の出し方 kanabun 09/1/24(土) 10:35 発言
【60026】Re:年間月別合計の出し方 kanabun 09/1/24(土) 10:40 発言
【60036】Re:年間月別合計の出し方 ひかる 09/1/24(土) 19:18 お礼
【60054】Re:年間月別合計の出し方 ひかる 09/1/26(月) 11:50 質問
【60061】Re:年間月別合計の出し方 kanabun 09/1/26(月) 14:39 発言
【60097】Re:年間月別合計の出し方 ひかる 09/1/27(火) 12:42 お礼
【60105】Re:年間月別合計の出し方 kanabun 09/1/27(火) 15:56 発言
【60106】Re:年間月別合計の出し方 ひかる 09/1/27(火) 16:27 お礼
【59889】Re:年間月別合計の出し方 kanabun 09/1/15(木) 16:48 発言

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