| |
「こもと さん」では有りませんが
こんなのでは
Sub test_2()
Const strPrefix As String = "CA"
Dim myD As Object
Dim i As Long, tbl
' Dim MyLen As Integer
' Dim MyCA As Variant
Set myD = CreateObject("Scripting.Dictionary")
'========================================================================
tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Columns("A").Value
For i = 1 To UBound(tbl)
myD.Add tbl(i, 1), ""
Next i
' With Worksheets(2)
With Worksheets("Sheet1")
tbl = .Range("A2").CurrentRegion.Columns("A:B").Value
For i = 1 To UBound(tbl)
If myD.exists(tbl(i, 1)) Then
If tbl(i, 2) Like strPrefix & "*" Then
tbl(i, 2) = Mid(tbl(i, 2), Len(strPrefix) + 1)
End If
If Not myD.exists(tbl(i, 2)) Then
myD.Add tbl(i, 2), ""
End If
End If
Next i
For i = UBound(tbl) To 1 Step -1
If myD.exists(tbl(i, 1)) Then
.Range("C" & i).Value = "X"
End If
Next i
End With
End Sub
なお、
>2行 | BBB CABBB ←削除（CAから始まる為、BBBがキーとなってます）
は、親と次を指し示す子が同じなのは、データ的に変なのでは？
また、私のコードでは以下の様に成ります
前回、書き忘れましたが私のコードでは、
Sheet1、Sheet2共に列見出しが有る物とします
（もし列見出しが無い場合は、上に1行列見出しを入れて下さい）
また、今回は、削除の確認の為オートフィルタが最後に掛かって終わる様にして有ります
Option Explicit
Public Sub Sample_3()
' オートフィルタに因る削除データの表示版
'◆Listのデータ列数（A列〜D列）
Const clngColumns As Long = 4
'◆Listの中の親と成る列位置(基準列からの列Offset：1列目)
Const clngKey1 As Long = 0
'◆Listの中の子と成る列位置(基準列からの列Offset：2列目)
Const clngKey2 As Long = 1
'B列に付く可能性の有る接頭子
Const cstrPrefix As String = "CA"
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 lngCount As Long
Dim strProm As String
Dim sngTime1 As Single
Dim sngTime2 As Single
sngTime2 = Timer
'◆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
If .Parent.FilterMode Then
.Parent.UsedRange.AutoFilter
End If
'行数の取得
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のA列全て）
For i = 1 To UBound(vntDelete, 1) - 1
DataDelete vntDelete(i, 1), vntList, 1, vntFlags(), lngCount, cstrPrefix
Next i
With rngList
'削除行が有るなら
If lngCount > 0 Then
'フラグを出力
.Offset(, clngColumns).EntireColumn.ClearComments
.Offset(, clngColumns).Value = "削除フラグ"
.Offset(1, clngColumns).Resize(lngRows).Value = vntFlags
'フラグをKeyとしてオートフィルタを掛ける
.Resize(lngRows + 1, clngColumns + 1).AutoFilter _
Field:=clngColumns + 1, Criteria1:="=×", Operator:=xlAnd
End If
End With
strProm = "処理が完了しました"
Wayout:
Set rngList = Nothing
Set rngDelete = Nothing
sngTime1 = Timer
MsgBox strProm & vbLf & (sngTime1 - sngTime2), vbInformation
End Sub
Private Sub DataDelete(vntKey As Variant, _
vntList As Variant, _
lngRow As Long, _
vntFlags() As Variant, _
lngCount As Long, _
strPrefix As String)
'A列最終行まで繰り返し
Do Until IsEmpty(vntList(0)(lngRow, 1))
'探索KeyとA列の値が同じなら
If vntKey = vntList(0)(lngRow, 1) Then
'A列と同位のB列の値に"CA"が付いている場合
If vntList(1)(lngRow, 1) Like strPrefix & "*" Then '★追加
'"CA"を取り除いた値の変換
vntList(1)(lngRow, 1) = Mid(vntList(1)(lngRow, 1), Len(strPrefix) + 1) '★追加
End If '★追加
'削除フラグに削除記号がないなら
If IsEmpty(vntFlags(lngRow, 1)) Then '★追加
'フラグを立てる
vntFlags(lngRow, 1) = "×" '★変更
'削除数を更新
lngCount = lngCount + 1
End If '★追加
'もし、A列と同位のB列の値がA列の値と等しくないなら（データ不良を避ける）
If vntList(0)(lngRow, 1) <> vntList(1)(lngRow, 1) Then
'B列の値を探しに再帰呼び出しを行う
DataDelete vntList(1)(lngRow, 1), vntList, 1, vntFlags(), lngCount, strPrefix
End If
End If
'次の行に更新
lngRow = lngRow + 1
Loop
End Sub
|
|
Hirofumi
- 09/11/4(水) 13:26 -
