| |
結果の出力位置を間違えた様で？
以下を修正して下さい
'データを転記
' rngList.Offset(lngTop - 1, clngColumns - 2) _
.Resize(lngCount).Value = vntResult
'データを転記
rngList.Offset(lngTop - 1, clngColumns - 1) _
.Resize(lngCount).Value = vntResult '★変更
また、削除も同時に行うなら、こんなかな？
Option Explicit
Public Sub Sample2()
'元々のデータ列数（B列〜E列）
Const clngColumns As Long = 4
'グループの有る列(基準列B列からのC列の列Offset)
Const clngGroup As Long = 1
Dim i As Long
Dim lngRows As Long
Dim lngTop As Long
Dim lngCount As Long
Dim rngList As Range
Dim vntData As Variant
Dim vntGroup As Variant
Dim vntItems As Variant
Dim strProm As String
'画面更新を停止
' Application.ScreenUpdating = False
'Listの先頭セル位置を基準とする（A列の列見出しのセル位置）
Set rngList = ActiveSheet.Cells(1, "B")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row + 1
If lngRows <= 0 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim vntData(1 To lngRows, 1 To 1)
For i = 1 To lngRows
vntData(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(, clngColumns).Resize(lngRows).Value = vntData
'データをC列で整列
DataSort .Resize(lngRows, clngColumns + 1), .Offset(, clngGroup)
'復帰用Keyの再取得
vntData = .Offset(, clngColumns).Resize(lngRows + 1).Value
'C列データを配列に取得
vntGroup = .Offset(, clngGroup).Resize(lngRows + 1).Value
'B列データを配列に取得
vntItems = .Resize(lngRows + 1).Value
End With
'注目値の位置を記録
lngTop = 1
'削除行数のカウント初期値
lngCount = 0
For i = 2 To lngRows + 1
'注目値と現在値が違った場合
If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
'注目値の位置を記録
lngTop = i
Else
'結果用変数に「・」を挟んで追加
vntItems(lngTop, 1) = vntItems(lngTop, 1) & "・" & vntItems(i, 1)
'削除行の復帰用KeyをEmptyに
vntData(i, 1) = Empty
'削除行数を更新
lngCount = lngCount + 1
End If
Next i
With rngList
'結果を出力
.Offset(, clngColumns - 1).Resize(lngRows).Value = vntItems
'復帰用Keyの出力
.Offset(, clngColumns).Resize(lngRows).Value = vntData
'元データを復帰
DataSort .Resize(lngRows, clngColumns + 1), .Offset(1, clngColumns)
If lngCount > 0 Then
'削除行を削除
.Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
End If
'復帰用Key列を削除
.Offset(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
|
|
Hirofumi
- 06/8/15(火) 13:11 -
