| |
こんなでは？
Sheet2のB1セルの日付はシリアル値（セル書式はなんでも可、シリアル値はB1だけでも可）で在る事
Sheet1の日付は「12/1/10」形式の文字列で在る
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows 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).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'日付先頭、最終を取得
vntMin = .Offset(, 1).Value2
vntMax = vntMin + 90 - 1
'A列データを配列として取得
vntData = .Offset(1).Resize(lngRows + 1).Value
'A列データをDictionaryに登録
For i = 1 To lngRows
dicIndex.Item(vntData(i, 1)) = i
Next i
End With
'結果出力用配列を確保(2次元目は日付のシリアル値と同じにして置く)
ReDim vntResult(1 To lngRows, vntMin To vntMax)
'Sheet1に就いて
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, 1).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'Sheet1先頭〜最終迄繰り返し
For i = 1 To lngRows
'Sheet1から1行分配列として取得
vntData = rngList.Offset(i).Resize(, 4).Value
'日付をシリアル値に変換
vntData(1, 3) = GetDate(vntData(1, 3))
'日付がSheet2の範囲内で
If vntMin <= vntData(1, 3) And vntData(1, 3) <= vntMax Then
'品番がSheet2に在るなら
If dicIndex.Exists(vntData(1, 2)) Then
'個数を出力用配列に加算
vntResult(dicIndex.Item(vntData(1, 2)), vntData(1, 3)) _
= vntResult(dicIndex.Item(vntData(1, 2)), vntData(1, 3)) + vntData(1, 4)
End If
End If
Next i
With rngResult.Offset(1, 1).Resize(UBound(vntResult, 1), vntMax - vntMin + 1)
'結果範囲を消去
.ClearContents
'結果を出力
.Value = vntResult
End With
strProm = "処理が完了しました"
Wayout:
Set dicIndex = Nothing
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
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)
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}
