Excel VBA質問箱 IV

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

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


43423 / 76732 ←次へ | 前へ→

【38357】Re:検索〜比較〜行削除
回答  Hirofumi  - 06/5/31(水) 20:02 -

引用なし
パスワード
   もう見て居ないかな?

こんなのも有るよ

Option Explicit

Public Sub Repetition()

  'データの列数(基準位置からの列数、この列の1列外側を作業列にします)
  '例えば、基準セル位置がA列で、データがAB列まで有るなら
  Const clngColumns As Long = 28

  '重複を比較する列(基準列位置からの列Offset)
  '例えば、基準セル位置がA列で、比較列がAB列なら
  Const clngKeys As Long = 27
  
  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
  'Flagを格納する配列を確保
  ReDim lngFlags(1 To lngRows, 1 To 1)

  Application.ScreenUpdating = False

  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")

  With dicIndex
    'データ行数分繰り返し
    For i = 1 To lngRows
      'Keyの登録が有るなら(重複が有る)
      If .Exists(vntData(i, 1)) Then
        '削除フラグを立てる
        lngFlags(i, 1) = 1
        '削除数をカウント
        lngCount = lngCount + 1
      Else
        'Keyの登録
        .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
      '削除フラグの列をKeyとして整列
      .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 = "重複行が有りません"
      GoTo Wayout
    End If
  End With

Wayout:

  Application.ScreenUpdating = True

  Set rngList = Nothing

  MsgBox strProm, vbInformation

End Sub
0 hits

【38314】検索〜比較〜行削除 ゆっけ 06/5/31(水) 11:04 質問
【38317】Re:検索〜比較〜行削除 Statis 06/5/31(水) 11:29 回答
【38324】Re:検索〜比較〜行削除 ゆっけ 06/5/31(水) 13:00 質問
【38328】Re:検索〜比較〜行削除 Kein 06/5/31(水) 13:45 回答
【38351】Re:検索〜比較〜行削除 ゆっけ 06/5/31(水) 16:12 質問
【38352】Re:検索〜比較〜行削除 Kein 06/5/31(水) 16:30 発言
【38353】Re:検索〜比較〜行削除 ゆっけ 06/5/31(水) 17:55 お礼
【38372】Re:検索〜比較〜行削除 samugar 06/6/1(木) 8:33 発言
【38357】Re:検索〜比較〜行削除 Hirofumi 06/5/31(水) 20:02 回答

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