| |
Sheet1が以下の様に成って居るとします
A B C D E F G
1 年月日 検疫サンプル名 24:00 06:00 12:00 18:00 計
2 20051201 prokih-hkc001 20 10 18 22 70
3 20051201 prokih-hkc111 20 10 18 20 68
4 20051201 prokih-hkc001 20 10 18 22 70
5 ・
Option Explicit
Public Sub Sample()
'データ列数
Const clngColumns As Long = 7
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))
'IndexにKeyが有る場合
If .Exists(vntKey) Then
'Sheet2からデータ部分を配列に取得
vntResult = rngResult.Offset(.Item(vntKey), 2) _
.Resize(, clngColumns - 2).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), 2) _
.Resize(, clngColumns - 2).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/2(月) 19:57 -
