| |
こうすれば善いと思います
Option Explicit
Public Sub Sample2()
'データ列数
Const clngColumns As Long = 30 '★変更
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim lngRow As Long
Dim rngList As Range
Dim vntData As Variant
Dim rngResult As Range
Dim vntResult As Variant
Dim dicIndex As Object
Dim vntKey As Variant
Dim strProm As String
'画面更新を停止
Application.ScreenUpdating = False
'データListの左上隅セル位置を基準として設定(列見出し「年月日」のセル位置)
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'出力Listの左上隅セル位置を基準として設定(列見出し「年月日」のセル位置)
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
With rngResult
'Sheet2をクリア
.Parent.Cells.Clear
'列見出しをSheet2にCopy
rngList.Resize(, clngColumns).Copy _
Destination:=.Item(1)
End With
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
lngRow = 1
For i = 1 To lngRows
'データを配列に取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
'探索Keyの作成
vntKey = CStr(vntData(1, 1)) _
& vbTab & CStr(vntData(1, 2)) _
& vbTab & CStr(vntData(1, 3)) '★変更
'IndexにKeyが有る場合
If .Exists(vntKey) Then
'Sheet2からデータ部分を配列に取得
vntResult = rngResult.Offset(.Item(vntKey), 3) _
.Resize(, clngColumns - 3).Value '★変更
'データを集計
For j = 1 To UBound(vntResult, 2)
vntResult(1, j) = Val(vntResult(1, j)) _
+ Val(vntData(1, j + 2))
Next j
'集計配列を元の位置に出力
rngResult.Offset(.Item(vntKey), 3) _
.Resize(, clngColumns - 3).Value = vntResult '★変更
Else
'Sheet1の1行をSheet2にCopy
rngList.Offset(i).Resize(, clngColumns).Copy _
Destination:=rngResult.Offset(lngRow)
'IndexにKeyとSheet2の出力行位置を登録
.Item(vntKey) = lngRow
'出力行位置を更新
lngRow = lngRow + 1
End If
Next i
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
Set dicIndex = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 06/1/4(水) 20:55 -
