Excel VBA質問箱 IV

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

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


22760 / 76732 ←次へ | 前へ→

【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

0 hits

【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 回答

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