Excel VBA質問箱 IV

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

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


18750 / 76738 ←次へ | 前へ→

【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
0 hits

【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 お礼

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