| |
こんなのでは？
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim wksList As Worksheet
Dim wksResult As Worksheet
Dim lngTop As Long
Dim lngCount As Long
Dim strProm As String
Set wksList = Worksheets("Sheet1")
'仮にデータの在るシートと同じにしておく
Set wksResult = wksList
'行位置の取得
lngRows = wksList.Cells(Rows.Count, "A").End(xlUp).Row
'画面更新を停止
Application.ScreenUpdating = False
With wksList
'日付先頭位置を初期値に
lngTop = 1
'同一日付のカウントを初期化
lngCount = 1
'日付列に就いて繰り返し
For i = 2 To lngRows + 1
'日付先頭と日付が違うなら
If .Cells(lngTop, "A").Value <> .Cells(i, "A").Value Then
'出力シートを取得
GetSheet wksResult
'日付を転記
wksResult.Cells(1, "A").Value = .Cells(lngTop, "A").Value
'名前を転記
.Cells(lngTop, "B").Resize(lngCount).Copy _
Destination:=wksResult.Cells(2, "A")
'日付先頭位置を更新
lngTop = i
'同一日付のカウントを初期化
lngCount = 1
Else
'同一日付のカウントを更新
lngCount = lngCount + 1
End If
Next i
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set wksList = Nothing
Set wksResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub GetSheet(wksMark As Worksheet)
Dim i As Long
On Error GoTo ErrorHandler
For i = 1 To Worksheets.Count
If wksMark.Name = Worksheets(i).Name Then
Exit For
End If
Next i
Set wksMark = Worksheets(i + 1)
wksMark.UsedRange.ClearContents
Exit Sub
ErrorHandler:
Set wksMark = Worksheets.Add(After:=wksMark)
End Sub
|
|
Hirofumi
- 12/3/7(水) 0:58 -
