Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


3228 / 13644 ツリー ←次へ | 前へ→

【63411】リスト削除 たつ 09/11/2(月) 14:26 質問[未読]
【63413】Re:リスト削除 Yuki 09/11/2(月) 15:07 発言[未読]
【63415】Re:リスト削除 たつ 09/11/2(月) 15:21 発言[未読]
【63414】Re:リスト削除 こもと 09/11/2(月) 15:17 発言[未読]
【63417】Re:リスト削除 たつ 09/11/2(月) 15:52 質問[未読]
【63419】Re:リスト削除 こもと 09/11/2(月) 16:56 発言[未読]
【63418】Re:リスト削除 たつ 09/11/2(月) 16:54 質問[未読]
【63421】Re:リスト削除 こもと 09/11/2(月) 17:09 発言[未読]
【63431】Re:リスト削除 たつ 09/11/3(火) 14:45 お礼[未読]
【63442】Re:リスト削除 たつ 09/11/4(水) 8:39 質問[未読]
【63443】Re:リスト削除 Hirofumi 09/11/4(水) 13:26 発言[未読]
【63444】Re:リスト削除 たつ 09/11/4(水) 15:16 質問[未読]
【63445】Re:リスト削除 Hirofumi 09/11/4(水) 15:43 回答[未読]
【63447】Re:リスト削除 たつ 09/11/5(木) 11:25 お礼[未読]
【63446】Re:リスト削除 kanabun 09/11/4(水) 16:07 発言[未読]
【63425】Re:リスト削除 SS 09/11/2(月) 20:05 発言[未読]
【63432】Re:リスト削除 たつ 09/11/3(火) 14:47 お礼[未読]
【63426】Re:リスト削除 Hirofumi 09/11/2(月) 20:15 回答[未読]
【63427】Re:リスト削除 Hirofumi 09/11/3(火) 12:29 回答[未読]
【63433】Re:リスト削除 たつ 09/11/3(火) 14:49 お礼[未読]
【63428】Re:リスト削除 arajin 09/11/3(火) 14:20 回答[未読]
【63429】Re:リスト削除 arajin 09/11/3(火) 14:25 回答[未読]
【63434】Re:リスト削除 たつ 09/11/3(火) 14:51 お礼[未読]

【63411】リスト削除
質問  たつ  - 09/11/2(月) 14:26 -

引用なし
パスワード
   どうしても、考えても考えても、思いつかない為、アドバイスをお願いします
この文章で言いたい事が伝わるか、心配ですが、何卒よろしくお願いします

【シート1】に6000件くらいのデータがあります。
【シート2】には削除したいリストがあります

【シート2】
BBB
YYY
HHH



とA列に削除したいのデータのリストがあります

【シート1】

      A列   B列
_____________________________
  |
1行 |   AAA   BBB
2行 |   BBB   CCC ←削除
3行 |   CCC   DDD ←削除
4行 |   BBB   EEE ←削除
5行 |   EEE   FFF ←削除
6行 |   FFF   GGG ←削除
7行 |   HHH   RRR
8行 |   RRR   TTT
9行 |   EEE   PPP ←削除   と6行分が削除の対象となります




まだまだ、実際はデータが続いています

例えば、【シート2】に載っている[BBB]という名前と繋がっていくものを【シート1】から行毎削除させたいのですが、どうしたらよいのか分かりません…

まず、[BBB]の名をA列から探し、その行は削除する行となるのですが、さらにその[BBB]が見つかった隣列[B列]の[CCC]をまた、A列から探し、削除する行となり、
また、更に[CCC]が見つかったら、隣列の[DDD]がA列にないか?探す…といった作業になります

A列は親部品となっており、その親部品に繋がるものを子部品(B列)に記載されていますので、結果、ずーっと親から繋がっていく子部品たちを削除するという事です

よろしくお願いします

【63413】Re:リスト削除
発言  Yuki  - 09/11/2(月) 15:07 -

引用なし
パスワード
   ▼たつ さん:
チョット疑問点です。

>      A列   B列
>_____________________________
>  |
>1行 |   AAA   BBB
>2行 |   BBB   CCC ←削除
>3行 |   CCC   DDD ←削除
>4行 |   BBB   EEE ←削除
>5行 |   EEE   FFF ←削除
>6行 |   FFF   GGG ←削除
>7行 |   HHH   RRR   <= この行は削除しないの?
>8行 |   RRR   TTT
>9行 |   EEE   PPP ←削除   と6行分が削除の対象となります
      ↑は切れているけど削除なの?(一回出てきたから?)

>・
>まだまだ、実際はデータが続いています
>
>例えば、【シート2】に載っている[BBB]という名前と繋がっていくものを【シート1】から行毎削除させたいのですが、どうしたらよいのか分かりません…
>
>まず、[BBB]の名をA列から探し、その行は削除する行となるのですが、さらにその[BBB]が見つかった隣列[B列]の[CCC]をまた、A列から探し、削除する行となり、
>また、更に[CCC]が見つかったら、隣列の[DDD]がA列にないか?探す…といった作業になります
>
>A列は親部品となっており、その親部品に繋がるものを子部品(B列)に記載されていますので、結果、ずーっと親から繋がっていく子部品たちを削除するという事です
>
>よろしくお願いします

【63414】Re:リスト削除
発言  こもと  - 09/11/2(月) 15:17 -

引用なし
パスワード
   ▼たつ さん:

かならず親部品が最初に現れている条件であれば
以下のような感じでどうでしょうか?

Sub test()
Dim myD As Object, i As Long, tbl
Set myD = CreateObject("Scripting.Dictionary")

'シート2のA列の部品をすべて削除なら
'========================================================================
'tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Columns("A").Value
'For i = 1 To UBound(tbl)
' myD.Add tbl(i, 1), ""
'Next i
'========================================================================

'BBBだけなら
'========================================================================
 myD.Add "BBB", ""
'========================================================================

With Worksheets("Sheet1")
 tbl = .Range("A1").CurrentRegion.Columns("A:B").Value
 For i = 1 To UBound(tbl)
  If myD.Exists(tbl(i, 1)) Then myD.Add tbl(i, 2), ""
 Next i
 For i = UBound(tbl) To 1 Step -1
  If myD.Exists(tbl(i, 1)) Then .Rows(i).Delete
 Next i
End With
End Sub

【63415】Re:リスト削除
発言  たつ  - 09/11/2(月) 15:21 -

引用なし
パスワード
   ▼Yuki さん:
>▼たつ さん:
>チョット疑問点です。
>
>>      A列   B列
>>_____________________________
>>  |
>>1行 |   AAA   BBB
>>2行 |   BBB   CCC ←削除
>>3行 |   CCC   DDD ←削除
>>4行 |   BBB   EEE ←削除
>>5行 |   EEE   FFF ←削除
>>6行 |   FFF   GGG ←削除
>>7行 |   HHH   RRR   <= この行は削除しないの?
>>8行 |   RRR   TTT
>>9行 |   EEE   PPP ←削除   と6行分が削除の対象となります
>      ↑は切れているけど削除なの?(一回出てきたから?)
>

そうなんです。
一回出てきているから、こちらの名前も消さないといけないのです

何か、よい方法ありますでしょうか?

【63417】Re:リスト削除
質問  たつ  - 09/11/2(月) 15:52 -

引用なし
パスワード
   ▼こもと さん:

アドバイスありがとうございました
少し説明が抜けていました。すみません
B列の名前は重複していることも多々あるということです。

下記の通り、VBAを動かしてみましたところ、

B列に同じ名前が存在する為か、途中でエラーになってしまいます

>  If myD.Exists(tbl(i, 1)) Then myD.Add tbl(i, 2), ""

エラー内容は下記の通りです

実行時エラー ”457""
このキーは既にこのコレクションの要素に割り当てられています

【シート1】

      A列   B列
_____________________________
  |
1行 |   AAA   BBB
2行 |   BBB   CCC ←削除
3行 |   CCC   DDD ←削除
4行 |   BBB   EEE ←削除
5行 |   EEE   FFF ←削除
6行 |   FFF   GGG ←削除
7行 |   HHH   RRR
8行 |   RRR   TTT
9行 |   EEE   PPP ←削除 
10行 |  BBB   QQQ
11行 |  QQQ   FFF  ←ここで、過去に一度でた(FFF)がまた出てきてます





こちらはどのように回避したらいいのでしょうか?

何度もすみません…がよろしくお願いします

【63418】Re:リスト削除
質問  たつ  - 09/11/2(月) 16:54 -

引用なし
パスワード
   ▼こもと さん:

先ほどの重複した名前があるとエラーになるといった件ですが、
なんとか、自分なりに考えて解決しました

If myD.exists(tbl(i, 1)) Then myD.Add tbl(i, 2), ""
 ↓下記のようにしてみました
 If myD.exists(tbl(i, 1)) Then
  If Not myD.exists(tbl(i, 2)) Then
   myD.Add tbl(i, 2), ""
  End If
  End If

’-------------------------------------------
度々なんですが、問題が生じまして…

ちがう親の子にも、同じ名前の子が存在する為、
違う親の子の名前も削除してしまう結果となってしまってます…


【シート1】

      A列   B列
__________親名前____子名前_______________
  |  
1行 |   AAA   BBB
2行 |   BBB   CCC ←削除
3行 |   CCC   DDD ←削除
4行 |   BBB   EEE ←削除
5行 |   EEE   FFF ←削除
6行 |   FFF   GGG ←削除
7行 |   HHH   RRR
8行 |   RRR   TTT
9行 |   EEE   PPP ←削除
10行|   QQQ   BBB ←これは親が違う為、削除してはいけない

上記のようにある場合、10行目は削除する親とは繋がっていない為、削除しないように…というのは可能なんでしょうか??

すみません…

どんなに考えても答えが見つからないです

どうかよろしくお願いします

【63419】Re:リスト削除
発言  こもと  - 09/11/2(月) 16:56 -

引用なし
パスワード
   ▼たつ さん:
なるほど・・・

>B列に同じ名前が存在する為か、途中でエラーになってしまいます
>
>>  If myD.Exists(tbl(i, 1)) Then myD.Add tbl(i, 2), ""

この部分を

  If myD.Exists(tbl(i, 1)) Then
   If Not myD.Exists(tbl(i, 2)) Then myD.Add tbl(i, 2), ""
  End If

にしてみてください。

【63421】Re:リスト削除
発言  こもと  - 09/11/2(月) 17:09 -

引用なし
パスワード
   ▼たつ さん:
>ちがう親の子にも、同じ名前の子が存在する為、
>違う親の子の名前も削除してしまう結果となってしまってます…
>
>
>【シート1】
>
>      A列   B列
>__________親名前____子名前_______________
>  |  
>1行 |   AAA   BBB
>2行 |   BBB   CCC ←削除
>3行 |   CCC   DDD ←削除
>4行 |   BBB   EEE ←削除
>5行 |   EEE   FFF ←削除
>6行 |   FFF   GGG ←削除
>7行 |   HHH   RRR
>8行 |   RRR   TTT
>9行 |   EEE   PPP ←削除
>10行|   QQQ   BBB ←これは親が違う為、削除してはいけない
>
>上記のようにある場合、10行目は削除する親とは繋がっていない為、削除しないように…というのは可能なんでしょうか??
>
>すみません…
>
>どんなに考えても答えが見つからないです
>
>どうかよろしくお願いします

親が重複していない限り削除しないコードにしてるつもりなので
掲示されている例ですと10行目は削除されないと思うのですが・・・?

【63425】Re:リスト削除
発言  SS  - 09/11/2(月) 20:05 -

引用なし
パスワード
   ▼たつ さん:

興味がわいたので作ってみました。
削除すべき行の3列目に"○"印を付けるようにしています。
考え方はこれであっていますか?
合っていればEr内の整列と、下の行からの削除というように
改造する方法はいかがでしょうか。

Option Explicit

Sub test()
  Dim i As Long, j As Long, k As Long
  Dim r2 As Long, r1 As Long
  
  Dim dat As Variant, Er As Variant
  
  '削除対象読み込み
  With Worksheets("Sheet2")
    r2 = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim dat(1 To r2)
    For i = 1 To r2
      dat(i) = .Cells(i, 1).Value
    Next i
  End With
  With Worksheets("Sheet1")
    r1 = .Range("A" & Rows.Count).End(xlUp).Row
    ReDim Er(1 To 1)
    Do
      k = 0
      For i = 1 To r1
        If InStr(vbTab & Join(dat, vbTab) & vbTab, _
            vbTab & .Cells(i, 1).Value & vbTab) > 0 Then
          If InStr(vbTab & Join(Er, vbTab) & vbTab, _
              vbTab & i & vbTab) = 0 Then
            If Er(UBound(Er)) <> "" Then
              ReDim Preserve Er(1 To UBound(Er) + 1)
            End If
            Er(UBound(Er)) = i
          End If
          For j = 1 To UBound(dat)
            If InStr(vbTab & Join(dat, vbTab) & vbTab, _
              vbTab & .Cells(i, 2).Value & vbTab) = 0 Then
              If dat(UBound(dat)) <> "" Then
                ReDim Preserve dat(1 To UBound(dat) + 1)
              End If
              dat(UBound(dat)) = .Cells(i, 2).Value
              k = 1
            End If
          Next j
        Else
        End If
      Next i
    Loop While k = 1
    For i = 1 To UBound(Er)
      .Cells(Er(i), 3).Value = "○"
    Next i
  End With
End Sub

【63426】Re:リスト削除
回答  Hirofumi  - 09/11/2(月) 20:15 -

引用なし
パスワード
   面白そうなので作って見た物の、余り自信が有りません
再帰呼び出しを使っているので、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

【63427】Re:リスト削除
回答  Hirofumi  - 09/11/3(火) 12:29 -

引用なし
パスワード
   データが必ず親より下の行に子が有ると言う関係では無く
ランダムに並んでいるなら、以下のプロシージャの中を★印の様に変更して下さい


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()
      DataDeleteF vntList(1)(lngRow, 1), vntList, 1, vntFlags() '★変更
    End If
    lngRow = lngRow + 1
  Loop
  
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
      DataDelete vntList(1)(lngRow, 1), vntList, 1, lngFlags(), lngCount '★変更
    End If
    lngRow = lngRow + 1
  Loop
  
End Sub

【63428】Re:リスト削除
回答  arajin  - 09/11/3(火) 14:20 -

引用なし
パスワード
   面白そうなので、私も考えてみました。
やはり、Dictionaryを使いたくなりますね。

Sub Sample()
  Dim v As Variant, i As Long
  Dim r As Range
  Dim dic As Object, itm As Variant, ind As Variant
  Dim loopEnd As Boolean
  
  Set dic = CreateObject("scripting.dictionary")
  v = Sheets("Sheet2").Range("A1").CurrentRegion.Resize(, 1).Value
  For i = 1 To UBound(v)
    Set dic.Item(v(i, 1)) = New Collection
  Next
  Set r = Sheets("Sheet1").Range("A1").CurrentRegion
  v = r.Value

  Do
    loopEnd = False
    For i = 1 To UBound(v)
      If dic.Exists(v(i, 1)) Then
        On Error Resume Next
        dic.Item(v(i, 1)).Add i, CStr(i)
        On Error GoTo 0
        If Not dic.Exists(v(i, 2)) Then
          Set dic.Item(v(i, 2)) = New Collection
          loopEnd = True
        End If
      End If
    Next
  Loop While loopEnd

  ReDim vv(1 To UBound(v), 0)
  For Each itm In dic.Items
    For Each ind In itm
      vv(ind, 0) = "←削除対象"
    Next
  Next
  Set dic = Nothing
  r.Resize(, 1).Offset(, r.Columns.Count).Value = vv
End Sub


削除していい行の場合、空列セルに"←削除対象"と印をつけてみました。
あとは、その印を目印に行削除すればいいと思います。
なお、老婆心ながら、削除の際はその列で一旦ソートして、
削除したい行を上下どちらかに纏めてから削除して下さい。

Do 〜 Loopのところが肝ですが、あまり検証してないので誤ってたらごごめんなさい。

【63429】Re:リスト削除
回答  arajin  - 09/11/3(火) 14:25 -

引用なし
パスワード
   あっと、失礼。

配列へのデータ確保のところは、2列分だけで十分でしたので、
余計なデータをメモリーしなくても良いように、
念のため、
  Set r = Sheets("Sheet1").Range("A1").CurrentRegion
  v = r.Resize(, 2).Value
     ^^^^^^^^^^^
と2列限定にした方がいいですね。

【63431】Re:リスト削除
お礼  たつ  - 09/11/3(火) 14:45 -

引用なし
パスワード
   ▼こもと さん:

>
>親が重複していない限り削除しないコードにしてるつもりなので
>掲示されている例ですと10行目は削除されないと思うのですが・・・?

↑私の勘違いでした・・・
すみません
助かりました
ありがとうございました。

ただ、配列がいまいち勉強不足でして、今解読中です

【63432】Re:リスト削除
お礼  たつ  - 09/11/3(火) 14:47 -

引用なし
パスワード
   ▼SS さん:

ありがとうございます。
こちらの方法でも試してみます…
配列の意味がいまいちまだ理解できなくて、悪戦苦闘してますが、
また、不明な点がでてきたら、アドバイスいただけるとありがたいです

【63433】Re:リスト削除
お礼  たつ  - 09/11/3(火) 14:49 -

引用なし
パスワード
   ▼Hirofumi さん:

ありがとうございます
助かります…

こちらも、自分なりに今解読中です

まだ初心者の為、理解するのに時間がかかりそう・・・です。

【63434】Re:リスト削除
お礼  たつ  - 09/11/3(火) 14:51 -

引用なし
パスワード
   ▼arajin さん:

ありがとうございます。
助かります

こちらも今から、解読していきたいと思います

もし分からないところがあって質問するかもしれませんが・・・
よろしくお願いします

【63442】Re:リスト削除
質問  たつ  - 09/11/4(水) 8:39 -

引用なし
パスワード
   >▼こもと さん:
いろいろ教えてもらったんですが、もう一つ作らないといけないパターンがありまして…
これがどうもうまくいかず悩んでいます

【シート1】

      A列   B列
__________親名前____子名前_______________
  |  
1行 |   AAA   BBB
2行 |   BBB   CABBB ←削除(CAから始まる為、BBBがキーとなってます)
3行 |   BBB   CCC  ←削除
4行 |   CCC   DDD  ←削除
5行 |   BBB   EEE  ←削除
6行 |   EEE   FFF  ←削除
7行 |   FFF   GGG  ←削除
8行 |   HHH   RRR
9行 |   RRR   TTT
10行|   EEE   PPP  ←削除
11行|   WWW   YYY
12行|   YYY   ABC  
13行|   YYY   CAABC ←削除(CAから始まる為、ABCがキーとなってます)
14行|   ABC   EFG  ←削除

上記のように、[シート1]の中のB列に"CA"からはじまる名前があり、この"CA"を抜いた名前と繋がっているものを
順番に削除していきたいのですが、うまくいきません

例)CABBB ⇒ BBBがキーとなります

前に教えてもらったVBAを少し改造してみました
何でうまくいかないのか、伝授して頂けるとありがたいです


Sub test()
Dim myD As Object, i As Long, tbl
Dim MyLen As Integer
Dim MyCA As Variant
Set myD = CreateObject("Scripting.Dictionary")

'========================================================================
tbl = Worksheets(2).Range("A2").CurrentRegion.Columns("A:B").Value


For i = 1 To UBound(tbl)
 If Left(Cells(i, 2).Value, 2) = "CA" Then
   MyLen = Len(Cells(i, 2))
   MyCA = Right(Cells(i, 2).Value, MyLen - 2)
  
   For q = 1 To UBound(tbl)
    If Cells(q, 2).Value = MyCA Then
     If Not myD.exists(tbl(q, 2)) Then
      myD.Add tbl(q, 2), ""
           
     End If
     Exit For
    End If
  Next q
 End If
' myD.Add tbl(i, 1), ""

  Next i

With Worksheets(2)
 tbl = .Range("A2").CurrentRegion.Columns("A:B").Value
 For q = 1 To UBound(tbl) 
 
 If myD.exists(tbl(q, 1)) Then
 
 If Not myD.exists(tbl(q, 2)) Then

   myD.Add tbl(q, 2), ""
  End If
  End If

 
 Next q
 For q = UBound(tbl) To 1 Step -1

   If myD.exists(tbl(q, 1)) Then Range("C" & q).Value = "X"
  
 Next q
End With
End Sub

【63443】Re:リスト削除
発言  Hirofumi  - 09/11/4(水) 13:26 -

引用なし
パスワード
   「こもと さん」では有りませんが
こんなのでは

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

【63444】Re:リスト削除
質問  たつ  - 09/11/4(水) 15:16 -

引用なし
パスワード
   ▼Hirofumi さん:

ありがとうございます
なかなか解読ができなくて…

一つ聞きたいのですが、
下記のコードで , "" の部分はどういう意味なんでしょうか?
>    myD.Add tbl(i, 1), ""

どうしても分かりません
よろしくお願いします

【63445】Re:リスト削除
回答  Hirofumi  - 09/11/4(水) 15:43 -

引用なし
パスワード
   >一つ聞きたいのですが、
>下記のコードで , "" の部分はどういう意味なんでしょうか?
>>    myD.Add tbl(i, 1), ""
>
>どうしても分かりません
>よろしくお願いします

今回のAddメソッドは、
「Dictionary オブジェクトにキーと対の項目を追加します。」
この時に、「.Add」の前の「myD」Dictionaryのオブジェクト名を指定します
また、「tbl(i, 1)」はキーをしていますし、「""」は項目を指定しています

通常、「Dictionary オブジェクト」は字の如く登録して在るキーを元に辞書引きを行います
詰まり、キーである「tbl(i, 1)」を指定すれば、其れに関連付けてある項目を返して来ます
因って、此れを利用するのですが?
今回は、キーが登録して在るか、否かを判断する為だけに使用していますので、
特に項目に意味を持つ物を指定する事をしなくても善いのですが?
しかし、「object.Add key, item」のスタイルでキー登録する場合、必ず「item」が必要になる為
「""」若しくは、Empty等を指定してスタイルを合わせています

【63446】Re:リスト削除
発言  kanabun  - 09/11/4(水) 16:07 -

引用なし
パスワード
   ▼たつ さん:
こんにちは。おじゃまします。
(Windows 7 にアップグレードして はじめてのレスです)

遡及する案がたくさん出ていますが、
単純に上から削除アイテム追加して削除行にチェックしていったとき、
どんな不具合が出短でしたっけ?
再度 ↓で検証してみていただけませんか?

Sub Try1()
  Dim dic As Object
  Dim c As Range
  Set dic = CreateObject("Scripting.Dictionary")
  '[Sheet2] 削除リスト取得
  With Worksheets("Sheet2")
    For Each c In .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
     dic(c.Value) = Empty
    Next
  End With
  
  Dim r As Range
  Dim v, u, i As Long, ss As String
  With Worksheets("Sheet1")
    Set r = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
    v = r.Resize(, 2).Value
    With r.Columns(3)
      .ClearContents
      u = .Value
    End With
    For i = 1 To UBound(v) 'A列を上から順に調べる(遡及チェックなし)
      If dic.Exists(v(i, 1)) Then
        u(i, 1) = "←削除"
        ss = v(i, 2)
        If ss Like "CA*" Then ss = Mid$(ss, 3)
        dic(ss) = Empty
      End If
    Next
    With r.Columns(3)
      .Value = u
      '.specialcells(xlconstants).entirerow.delete
    End With
  End With
  Set dic = Nothing
End Sub

【63447】Re:リスト削除
お礼  たつ  - 09/11/5(木) 11:25 -

引用なし
パスワード
   ▼Hirofumi さん:

ありがとうございました。

お蔭様で、なんとなく見えてきました。

まだまだ模索中ですが、がんばってみます

3228 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free