Excel VBA質問箱 IV

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

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


3942 / 13644 ツリー ←次へ | 前へ→

【59341】月単位で合計を出す タンゴ 08/12/7(日) 11:26 質問[未読]
【59342】Re:月単位で合計を出す タンゴ 08/12/7(日) 11:29 質問[未読]
【59343】Re:月単位で合計を出す タンゴ 08/12/7(日) 11:31 質問[未読]
【59349】Re:月単位で合計を出す Hirofumi 08/12/7(日) 20:20 回答[未読]

【59341】月単位で合計を出す
質問  タンゴ  - 08/12/7(日) 11:26 -

引用なし
パスワード
   みなさんこんにちは。

      A            B       C      D
     日付          利益(1)  利益(2)  利益(3)
1 2008.12.06(金)   500   −380    
2 2008.12.04(水)         −750    520
3 2008.12.03(火)   930    440   −190
4 2008.11.28(金)   280    370    310
5 2008.11.20(木)  −110    150    94 
     .
     .
     .

最新の日付は常に1行目に入り、古い日付はそのたびに一段下にずれるという日別のとある集計表があります。やりたいことは、題名にある通り、月単位の合計を表示させたいのですがその方法が分かりません。表示させる場所は日別集計表最下段のすぐ下、上記でいうと6行目になります。表示は年・月で、これも新しい順に、

2008.12  1090
2008.11  1094
     . 
     .
     .

となるように出来ないでしょうか?なお、この月別合計をコンボボタンなどで一度押すと上記のように表示、もう一度押すと消えるようにしたのですが・・・

【59342】Re:月単位で合計を出す
質問  タンゴ  - 08/12/7(日) 11:29 -

引用なし
パスワード
   ▼タンゴ さん:

補足します。月別収支はB、C、D全ての合計をA列に表示する、です

【59343】Re:月単位で合計を出す
質問  タンゴ  - 08/12/7(日) 11:31 -

引用なし
パスワード
   すみません、修正です。

最後の、「もう一度押すと消えるようにしたのですが・・・」は「もう一度押すと消えるようにしたいのですが・・・」の間違いです

【59349】Re:月単位で合計を出す
回答  Hirofumi  - 08/12/7(日) 20:20 -

引用なし
パスワード
   データは日付降順で整列されている物とします
また、日付はシリアル値で入力されている物とします
尚、結果の月」は、月初の日付を書式で年月だけ表示する様にしています

コマンドボタンには、「Sub Main」を登録して下さい

Option Explicit

Public Sub Main()

  Dim lngRows As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  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
  End With

  '画面更新を停止
  Application.ScreenUpdating = False
  
  If Not DataDelete(rngList, lngRows) Then
    AddUp rngList, lngRows
  End If
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub AddUp(rngList As Range, lngRows As Long)

  '◆データ列数(A列〜D列)
  Const clngColumns As Long = 4
  
  Dim i As Long
  Dim j As Long
  Dim rngResult As Range
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim lngWrite As Long

  '出力位置を設定
  Set rngResult = rngList.Offset(lngRows)
  
  '列データを配列に取得
  vntData = rngList.Offset(1).Resize(lngRows + 1, clngColumns).Value
  
  '結果配列を確保
  ReDim vntResult(1 To 2)
  'データ先頭行を結果配列に集計
  vntResult(1) = DateSerial(Year(vntData(1, 1)), Month(vntData(1, 1)), 1)
'  vntResult(1) = DateSerial(Val(Left(vntData(1, 1), 4)), _
              Val(Mid(vntData(1, 1), 6, 2)), 1)
  For i = 2 To 4
    vntResult(2) = vntResult(2) + vntData(1, i)
  Next i
  For i = 2 To lngRows + 1
    'もし、月が代わったら
'    vntData(i, 1) = DateSerial(Val(Left(vntData(i, 1), 4)), _
                  Val(Mid(vntData(i, 1), 6, 2)), 1)
    If Format(vntData(i, 1), "yyyy/mm") <> Format(vntResult(1), "yyyy/mm") Then
      '結果を出力
      lngWrite = lngWrite + 1
      rngResult.Offset(lngWrite).Resize(, 2).Value = vntResult
      '結果配列を確保
      ReDim vntResult(1 To 2)
      '日付データを結果配列に変換代入
      If vntData(i, 1) <> "" Then
        vntResult(1) = DateSerial(Year(vntData(i, 1)), Month(vntData(i, 1)), 1)
      End If
    End If
    'データを結果配列に集計
    For j = 2 To 4
      vntResult(2) = vntResult(2) + vntData(i, j)
    Next j
  Next i
  
  '結果の日付の書式を変更
  rngResult.Offset(1).Resize(lngWrite).NumberFormat = "yyyy.mm"
  
  Set rngResult = Nothing
     
End Sub

Private Function DataDelete(rngList As Range, lngRows As Long) As Boolean

  Dim i As Long
  
  For i = lngRows To 1 Step -1
    If rngList.Offset(i).NumberFormat <> "yyyy.mm" Then
      Exit For
    End If
  Next i
  
  If i < lngRows Then
    rngList.Offset(i + 1).Resize(lngRows - i).EntireRow.Delete
    lngRows = i
    DataDelete = True
  End If
  
End Function

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