VBA 日付別に最大値の行を抽出して別シートに貼り付けたい

この様なシート１があります。行数は不定です。

　A列 B列　 C列　D列　E列　F列　G列　H列
20170101 1AA 6BB 15.1 C1C 6DD 1FF GG1
20170101 2AA 5BB 10.1 C2C 5DD 2FF GG2
20170102 3AA 4BB 11.1 C3C 4DD 3FF GG3
20170102 4AA 3BB 19.1 C4C 3DD 4FF GG4
20170103 5AA 2BB 15.1 C5C 2DD 5FF GG5
20170103 6AA 1BB 23.1 C6C 1DD 6FF GG6

これを日付別にD列の最大値を抽出した行のデータをシート２へ転記したいです。

シート２の結果
A列 B列　 C列　D列　E列　F列　G列　H列
20170101 1AA 6BB 15.1 C1C 6DD 1FF GG1
20170102 4AA 3BB 19.1 C4C 3DD 4FF GG4
20170103 6AA 1BB 23.1 C6C 1DD 6FF GG6

手動で行うなら日付でフィルターをかけ、D列を降順でソートし、1行目を
シート２へ貼り付けるといった感じになると思いますがこれをVBAでやったら
どうなるのかご教授願えますでしょうか。よろしくお願いします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2017/11/29 23:53

こんばんは！

一例です。
↓の画像のように両シートとも1行目は項目行でデータは2行目以降にあるとします。
Sheet2の1行目項目は入力済みだという前提です。
標準モジュールです。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long
Dim c As Range, wS As Worksheet, myMax As Variant

Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow, "H")).ClearContents
End If
With Worksheets("Sheet1")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(k, "A") = wS.Cells(i, "A") Then
myMax = WorksheetFunction.Max(myMax, .Cells(k, "D"))
End If
Next k
Set c = .Range("D:D").Find(what:=myMax, LookIn:=xlValues, lookat:=xlWhole)
wS.Cells(i, "B").Resize(, 7).Value = .Cells(c.Row, "B").Resize(, 7).Value
myMax = Empty
Next i
End With
Application.ScreenUpdating = True
wS.Activate
MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

短時間でのご回答、誠にありがとうございます。
すごく勉強になります、助かりました。
またよろしくお願い致します。

お礼日時：2017/12/02 15:56