| |
>自分なりに考えた流れは…
>Ａ列をソート
>↓
>繰り返し文の中で、
>If Range("A(i)") = Range("A(i)").Offset(1).Value Then
>何かまとめる（配列？）変数＝A(i).Offset(1).Value
>何かまとめる（配列？）変数の中の行だけを削除
>と言う流れを考えていました。
>この流れでは無理でしょうか？
この流れをコードにするとこんなかな？
ただし、Testでは、不連続な削除行数61行を超えるとエラーに成りました
Public Sub Repetition3()
'データの列数
'例えば、基準セル位置がA列で、データがC列まで有るなら
Const clngColumns As Long = 3
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim strDelete As String
Dim strProm As String
'データの左上隅を基準とする
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'データKeyで整列
.Resize(lngRows, clngColumns).Sort _
Key1:=.Item(1, 1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
End With
With rngList
'データ行数分繰り返し
For i = 1 To lngRows - 1
'削除する行が合った場合
If .Offset(i - 1).Value = .Offset(i).Value Then
If strDelete <> "" Then
strDelete = strDelete & ","
End If
'削除位置を記録
strDelete = strDelete & .Offset(i).Address(False, False)
End If
Next i
End With
'行削除
If strDelete <> "" Then
rngList.Parent.Range(strDelete).EntireRow.Delete
strProm = "削除処理が完了しました"
Else
strProm = "削除行が有りません"
End If
Wayout:
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
Excelは、セル1つづつに対して読み書きを行う作業は、非常に遅く成ります
また、列、行の削除、挿入を遅い作業と成ります
因って、配列を使用した読み書き、連続した範囲の一括削除を心掛けます
一番遅い部類の重複削除（1セルづつ比較して、１行づつ削除）
Public Sub Repetition4()
'データの列数
'例えば、基準セル位置がA列で、データがC列まで有るなら
Const clngColumns As Long = 3
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim strProm As String
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'データKeyで整列
.Resize(lngRows, clngColumns).Sort _
Key1:=.Item(1, 1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
End With
With rngList
For i = lngRows - 1 To 1 Step -1
If .Offset(i - 1).Value = .Offset(i).Value Then
.Offset(i).EntireRow.Delete
End If
Next i
End With
strProm = "削除処理が完了しました"
Wayout:
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
速い部類の重複削除
Public Sub Repetition2()
Const clngColumns As Long = 3
Const clngKeys As Long = 0
Dim i As Long
Dim lngRows As Long
Dim lngCount As Long
Dim rngList As Range
Dim vntData As Variant
Dim dicIndex As Object
Dim lngFlags() As Long
Dim strProm As String
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row, _
clngKeys).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'Keyを配列に取得
vntData = .Offset(, clngKeys).Resize(lngRows + 1).Value
End With
ReDim lngFlags(1 To lngRows, 1 To 1)
Set dicIndex = CreateObject("Scripting.Dictionary")
With dicIndex
For i = 1 To lngRows
If .Exists(vntData(i, 1)) Then
lngFlags(i, 1) = 1
lngCount = lngCount + 1
Else
.Add vntData(i, 1), Empty
End If
Next i
End With
Set dicIndex = Nothing
With rngList
If lngCount > 0 Then
.Offset(, clngColumns).Resize(lngRows).Value = lngFlags
.Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
.Offset(lngRows - lngCount) _
.Resize(lngCount).EntireRow.Delete
.Offset(, clngColumns).EntireColumn.ClearContents
strProm = lngCount & "件の削除処理が完了しました"
Else
strProm = "重複行が有りません"
End If
End With
Wayout:
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
これが、最悪かも？、COUNTIFは行数が増えると加速度的に遅くなります
また、SpecialCellsは、不連続な削除行が8192を超すと非常に遅く成る等の問題有るようです？
Test環境では、8192を超すと全ての行が削除されました
Public Sub Repetition5()
Const clngColumns As Long = 3
Dim lngRows As Long
Dim rngList As Range
Dim strProm As String
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
With rngList.Offset(, clngColumns).Resize(lngRows)
.FormulaR1C1 = "=IF(COUNTIF(R" & rngList.Row _
& "C" & rngList.Column _
& ":RC[-" & clngColumns & "],RC[-" _
& clngColumns & "])>1,"""",""1"")"
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
rngList.Offset(, clngColumns).EntireColumn.Delete
strProm = "削除処理が完了しました"
Wayout:
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 07/6/5(火) 23:02 -
