| |
こんな手順で出来ると思います
1、Sheets("data")を、「NAME」昇順、「BUDHO」昇順、「CODE」昇順、「TYPE」昇順で整列
2、DataListの先頭行を取り出す
3、DataListの2行目を取り出す
4、1行目と2行目の「NAME,BUDHO,CODE,TYPE」を其々比較する
5、もし、1項目でも違うなら、1行目をSheets("data編集")へ出力
6、3行目を取り出し、2行目と3行目の比較を行う
7、項目全てが同じなら、2行目の「TIME」に3行目の「TIME」を加算
8、4行目を取り出し、2行目と比較、1項目でも違うなら、2行目をSheets("data編集")へ出力
9、此れを最終行の下まで行う（最終行の下の行をダミーデータとして使う）
Option Explicit
Option Compare Text
Public Sub Sample()
'◆DataListのデータ列数（A列〜F列）
Const clngColumns As Long = 6
Dim i As Long
Dim j As Long
Dim lngRow As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntResult As Variant
Dim vntData As Variant
Dim strProm As String
'◆DataListの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = Worksheets("data").Cells(1, "A")
'◆出力Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngResult = Worksheets("data編集").Cells(1, "A")
'画面更新を停止
' Application.ScreenUpdating = False
'"data編集"に就いて
With rngResult
'行数の取得（行末位置取得）
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
'結果を消去
If lngRows >= 1 Then
.Offset(1).Resize(lngRows, clngColumns).ClearContents
End If
End With
'"data"に就いて
With rngList
'行数の取得（行末位置取得）
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを「TYPE」昇順で整列
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(1, 4), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
'データを「NAME」昇順、「BUDHO」昇順、「CODE」昇順で整列
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(1, 1), Order1:=xlAscending, _
Key2:=.Offset(1, 2), Order2:=xlAscending, _
Key3:=.Offset(1, 3), Order3:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
End With
'先頭行を配列に取得
vntResult = rngList.Offset(1).Resize(, clngColumns).Value
'2行目以降最終行+1まで繰り返し
For i = 2 To lngRows + 1
'1行分データを取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
'前の行と「NAME,BUDHO,CODE,TYPE」を比較
For j = 2 To 5
'内容が違うならForを抜ける
If vntResult(1, j) <> vntData(1, j) Then
Exit For
End If
Next j
'内容が違う場合
If j <= 5 Then
'集計用配列（前の行データ）を"data編集"に出力
lngRow = lngRow + 1
rngResult.Offset(lngRow).Resize(, clngColumns).Value = vntResult
'集計用配列に現在データを代入
vntResult = vntData
Else
'集計用配列の「TIME」の列に現在行の「TIME」の列を加算
vntResult(1, 6) = vntResult(1, 6) + vntData(1, 6)
End If
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 08/9/18(木) 20:08 -
