|
こんなでも善いかも?
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim vntResult As Variant
Dim lngPos As Long
Dim vntComp As Variant
Dim strProm As String
'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
'データが無い場合
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Offset(, 2).Resize(lngRows + 1, 2).Value
End With
'画面更新を停止
Application.ScreenUpdating = False
'比較用変数に比較値を代入
vntComp = vntData(1, 1)
'結果用変数にD列の値を代入
vntResult = CStr(vntData(1, 2))
For i = 2 To lngRows + 1
'もし、比較用変数と比較値が違ったら
If vntData(i, 1) <> vntComp Then
'結果を出力
rngList.Offset(lngPos, 4).Value = vntResult
'位置を保存
lngPos = i - 1
'比較用変数の比較値を更新
vntComp = vntData(i, 1)
'結果用変数にD列の値を代入
vntResult = CStr(vntData(i, 2))
Else
'結果用変数にD列の値を連結
vntResult = vntResult & CStr(vntData(i, 2))
End If
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|