| |
後、日別の集計は、処理が幾分遅く成りますが？
今回の週別の集計とコードを揃える事が出来ますので
以下の様にしても善いかも？
以下のコード全てを同じ標準モジュールに記述して下さい
また、出力シートは実情に合わせて下さい
Option Explicit
Public Sub 日別集計()
MsgBox AddUp(Worksheets("Sheet1").Range("A1"), _
Worksheets("Sheet2").Range("A1"), 1), vbInformation
End Sub
Public Sub 週別集計()
MsgBox AddUp(Worksheets("Sheet1").Range("A1"), _
Worksheets("Sheet3").Range("A1"), 7), vbInformation
End Sub
Private Function AddUp(rngList As Range, rngResult As Range, lngMode As Long) As String
' 集計（日付が文字列タイプ）
Dim i As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim lngRow As Long
Dim lngColumn As Long
Dim vntData As Variant
Dim dicIndex As Object
Dim vntMax As Variant
Dim vntMin As Variant
Dim vntResult() As Variant
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'Sheet2に就いて
With rngResult
'行列数の取得
lngRows = .Offset(Rows.Count - .Row, 1).End(xlUp).Row - .Row
lngColumns = .Offset(, Columns.Count - .Column).End(xlToLeft).Column - .Column + 1
lngColumns = lngColumns - 2
If lngRows <= 0 Then
AddUp = .Parent.Name & "データが有りません"
GoTo Wayout
End If
'日付先頭、最終を取得
vntMin = .Offset(, 2).Value2
vntMax = vntMin + (lngColumns) * lngMode - 1
'B列データを配列として取得
vntData = .Offset(1, 1).Resize(lngRows + 1).Value
'B列データをDictionaryに登録
For i = 1 To lngRows
dicIndex.Item(CStr(vntData(i, 1))) = i
Next i
End With
'結果出力用配列を確保
ReDim vntResult(1 To lngRows, 0 To lngColumns - 1)
'Sheet1に就いて
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, 1).End(xlUp).Row - .Row
If lngRows <= 0 Then
AddUp = .Parent.Name & "データが有りません"
GoTo Wayout
End If
'3列分データを配列として取得
vntData = .Offset(1).Resize(lngRows, 3).Value
End With
'Sheet1先頭〜最終迄繰り返し
For i = 1 To lngRows
'日付をシリアル値に変換
vntData(i, 2) = GetDate(vntData(i, 2))
'日付がSheet2の範囲内で
If vntMin <= vntData(i, 2) And vntData(i, 2) <= vntMax Then
'日付がどの週に成るかを計算
lngColumn = (vntData(i, 2) - vntMin) \ lngMode
With dicIndex
'品番がSheet2に在るなら
If .Exists(CStr(vntData(i, 1))) Then
lngRow = .Item(CStr(vntData(i, 1)))
'個数を出力用配列に加算
vntResult(lngRow, lngColumn) _
= vntResult(lngRow, lngColumn) + vntData(i, 3)
End If
End With
End If
Next i
With rngResult.Offset(1, 2).Resize(UBound(vntResult, 1), lngColumns)
'結果範囲を消去
.ClearContents
'結果を出力
.Value = vntResult
End With
AddUp = "処理が完了しました"
Wayout:
Set dicIndex = Nothing
End Function
Private Function GetDate(vntValue As Variant) As Variant
Dim lngPos1 As Long
Dim lngPos2 As Long
GetDate = -1
lngPos1 = InStr(1, vntValue, "/", vbBinaryCompare)
If lngPos1 = 0 Then
Exit Function
End If
lngPos2 = InStr(lngPos1 + 1, vntValue, "/", vbBinaryCompare)
If lngPos2 = 0 Then
Exit Function
End If
GetDate = DateSerial(Val(Mid(vntValue, lngPos2 + 1)) + 2000, _
Val(Left(vntValue, lngPos1 - 1)), _
Val(Mid(vntValue, lngPos1 + 1, lngPos2 - lngPos1 - 1)))
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
