| |
データは日付降順で整列されている物とします
また、日付はシリアル値で入力されている物とします
尚、結果の月」は、月初の日付を書式で年月だけ表示する様にしています
コマンドボタンには、「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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
