| |
面白そうなので作って見た物の、余り自信が有りません
再帰呼び出しを使っているので、Shee1の6000行の時にスタックオーバーに成るかも？
また、処理は何度もSheet1のデータを行ったり来たりするので遅いと思います
なお、コードは処理確認用（削除行の最終列に「削除」の文字を出力するだけ）と
実処理用（実際に行削除を行うもの）の2つUpします
Option Explicit
Public Sub Sample_1()
' 処理確認用
'◆Listのデータ列数（A列〜B列）
Const clngColumns As Long = 2
'◆Listの中の親と成る列位置(基準列からの列Offset：1列目)
Const clngKey1 As Long = 0
'◆Listの中の子と成る列位置(基準列からの列Offset：2列目)
Const clngKey2 As Long = 1
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngDelete As Range
Dim vntList As Variant
Dim vntDelete As Variant
Dim vntFlags() As Variant
Dim strProm As String
'◆Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'◆結果出力の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngDelete = Worksheets("Sheet2").Cells(1, "A")
With rngDelete
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'列データを配列に取得
vntDelete = .Offset(1).Resize(lngRows + 1).Value
End With
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'親子データを格納する配列を確保
ReDim vntList(0 To 1)
'親列データを配列に取得
vntList(0) = .Offset(1, clngKey1).Resize(lngRows + 1).Value
'子列データを配列に取得
vntList(1) = .Offset(1, clngKey2).Resize(lngRows + 1).Value
'削除フラグを格納する配列を確保
ReDim vntFlags(1 To lngRows, 1 To 1)
End With
'削除行の抽出（Sheet2先頭の「BBB」だけ）
DataDeleteF vntDelete(1, 1), vntList, 1, vntFlags()
'削除行の抽出（Sheet2のA列全て）
' For i = 1 To UBound(vntDelete, 1) - 1
' DataDeleteF vntDelete(i, 1), vntList, 1, vntFlags()
' Next i
'画面更新を停止
' Application.ScreenUpdating = False
'フラグを出力
rngList.Offset(1, clngColumns).Resize(lngRows).Value = vntFlags
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngDelete = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataDeleteF(vntKey As Variant, _
vntList As Variant, _
lngRow As Long, _
vntFlags() As Variant)
Do Until vntList(0)(lngRow, 1) = ""
If vntKey = vntList(0)(lngRow, 1) Then
vntFlags(lngRow, 1) = "削除"
DataDeleteF vntList(1)(lngRow, 1), vntList, lngRow + 1, vntFlags()
End If
lngRow = lngRow + 1
Loop
End Sub
Public Sub Sample_2()
' データ削除
'◆Listのデータ列数（A列〜B列）
Const clngColumns As Long = 2
'◆Listの中の親と成る列位置(基準列からの列Offset：1列目)
Const clngKey1 As Long = 0
'◆Listの中の子と成る列位置(基準列からの列Offset：2列目)
Const clngKey2 As Long = 1
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngDelete As Range
Dim vntList As Variant
Dim vntDelete As Variant
Dim lngFlags() As Long
Dim lngCount As Long
Dim strProm As String
'◆Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'◆結果出力の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngDelete = Worksheets("Sheet2").Cells(1, "A")
With rngDelete
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
vntDelete = .Offset(1).Resize(lngRows + 1).Value
End With
With rngList
lngRows = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
ReDim vntList(0 To 1)
vntList(0) = .Offset(1, clngKey1).Resize(lngRows + 1).Value
vntList(1) = .Offset(1, clngKey2).Resize(lngRows + 1).Value
ReDim lngFlags(1 To lngRows, 1 To 1)
End With
'削除行の抽出（Sheet2先頭の「BBB」だけ）
' DataDelete vntDelete(1, 1), vntList, 1, lngFlags(), lngCount
'削除行の抽出（Sheet2のA列全て）
For i = 1 To UBound(vntDelete, 1) - 1
DataDelete vntDelete(i, 1), vntList, 1, lngFlags(), lngCount
Next i
Application.ScreenUpdating = False
With rngList
'削除行が有るなら
If lngCount > 0 Then
'フラグを出力
.Offset(1, clngColumns).Resize(lngRows).Value = lngFlags
'フラグをKeyとして整列（削除行を下に集める）
DataSort .Offset(1).Resize(lngRows, clngColumns + 1), .Offset(, clngColumns)
'フラグが立っている行を削除
.Offset(lngRows - lngCount + 1).Resize(lngCount, _
clngColumns + 1).Delete Shift:=xlShiftUp
'フラグ列を削除
.Offset(, clngColumns).EntireColumn.Delete
End If
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngDelete = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataDelete(vntKey As Variant, _
vntList As Variant, _
lngRow As Long, _
lngFlags() As Long, _
lngCount As Long)
Do Until vntList(0)(lngRow, 1) = ""
If vntKey = vntList(0)(lngRow, 1) Then
lngFlags(lngRow, 1) = 1
lngCount = lngCount + 1
DataDelete vntList(1)(lngRow, 1), vntList, lngRow + 1, lngFlags(), lngCount
End If
lngRow = lngRow + 1
Loop
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngSortOrder As Long = xlAscending, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=lngSortOrder, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
|
|
Hirofumi
- 09/11/2(月) 20:15 -
