| |
こんなのでは
ListはSheet1のA1から始まり、結果はSheet2に出力されます
Sheet1には、列見出しが有る物とします
Option Explicit
Public Sub Sample()
'元々のデータ列数（A列〜C列）
Const clngColumns As Long = 3
'「コード」の有る列(A列のA列からの列Offset)
Const clngGroup1 As Long = 1
'「日付」の有る列(B列のA列からの列Offset)
Const clngGroup2 As Long = 0
Dim i As Long
Dim lngRows As Long
Dim lngTop As Long
Dim lngWright As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntGroup As Variant
Dim strProm As String
'Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'結果出力の位置を設定
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngGroup1).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データに連番を付与（最終列の後ろに）
.Offset(, clngColumns).EntireColumn.Insert
With .Offset(1, clngColumns)
.Value = 1
.Resize(lngRows).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, _
Date:=xlDay, Step:=1, Trend:=False
End With
'データを「コード」、「日付」列をKeyとして整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngGroup1), Order1:=xlAscending, _
Key2:=.Offset(, clngGroup2), Order2:=xlDescending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'「コード」列データを配列に取得
vntGroup = .Offset(1, clngGroup1).Resize(lngRows + 1).Value
End With
'注目値の位置を記録
lngTop = 1
'先頭データを出力
For i = 2 To lngRows + 1
'注目値と現在値が違った場合
If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
'データを転記
lngWright = lngWright + 1
rngList.Offset(lngTop).Resize(, clngColumns).Copy _
Destination:=rngResult.Offset(lngWright)
'注目値の位置を記録
lngTop = i
End If
Next i
'データ位置の復帰
With rngList
'データを「コード」、「日付」列をKeyとして整列
.Offset(1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'連番削除
.Offset(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 09/9/15(火) 18:00 -
