| |
データシートはSheet1に在る物とします（ひぃちゃん さんのシート名にして下さい）
データシートのB列の日付は文字列ではありません 例）2010/1/1（B1タイトルB2以降データ）
データ出力先はSheet2とします（ひぃちゃん さんのシート名にして下さい）
データ出力先のB列の値とデータシートのA列の値を比較します
データ出力先のC1の日付はシリアル値（日付連番）とします
データ出力先の日付は、C1を先頭として値は月の1日とします（例「2010/10/1」でセル書式は何でも可）
データ出力先の日付は、最終列を検出しているので、6ヵ月で無くても可
連続した月なら3ヵ月でも12ヵ月でも、C1〜最終列迄の列数＝月数と成ります
尚、データシートのB列の日付はコード上で月の1日と変換します
多分大丈夫だと思いますが？、データシート、データ出力先の品番はコード上で全て文字列として扱います
Option Explicit
Public Sub Sample_4()
' ６ヵ月集計
Dim i As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim lngRow As Long
Dim lngColumn As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim dicIndex As Object
Dim vntMax As Variant
Dim vntMin As Variant
Dim vntResult() As Variant
Dim strProm As String
'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("Sheet1").Range("A1")
'結果出力の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngResult = Worksheets("Sheet2").Range("A1")
'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
strProm = "データが有りません"
GoTo Wayout
End If
'日付先頭、最終を取得
vntMin = .Offset(, 2).Value2
vntMin = DateSerial(Year(vntMin), Month(vntMin), 1)
vntMax = DateSerial(Year(vntMin), Month(vntMin) + lngColumns - 1, 1)
'日付列をDictionaryに登録
For i = 0 To lngColumns - 1
dicIndex.Item(Format(DateSerial(Year(vntMin), Month(vntMin) + i, 1), "yyyy/m/d")) = i
Next i
'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
'結果出力用配列を確保(2次元目は日付のシリアル値と同じにして置く)
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
strProm = "データが有りません"
GoTo Wayout
End If
'3列分データを配列として取得
vntData = .Offset(1).Resize(lngRows, 3).Value
End With
'Sheet1先頭〜最終迄繰り返し
For i = 1 To lngRows
'日付を月の1日に変換
vntData(i, 2) = DateSerial(Year(vntData(i, 2)), Month(vntData(i, 2)), 1)
'日付がSheet2の範囲内で
If vntMin <= vntData(i, 2) And vntData(i, 2) <= vntMax Then
With dicIndex
'品番がSheet2に在るなら
If .Exists(CStr(vntData(i, 1))) Then
lngRow = .Item(CStr(vntData(i, 1)))
lngColumn = .Item(Format(vntData(i, 2), "yyyy/m/d"))
'個数を出力用配列に加算
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
strProm = "処理が完了しました"
Wayout:
Set dicIndex = Nothing
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/10/27(水) 23:38 -
