Excel VBA質問箱 IV

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

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


15467 / 76738 ←次へ | 前へ→

【66748】Re:重複する行を削除したい
回答  Hirofumi  - 10/10/3(日) 15:43 -

引用なし
パスワード
   Dictionayを使うとこんなかな?
列見出しが有る物とします
データは、A列〜B列の2列とし、重複を見るKeyは、A列に有るとします
C列を作業列として使用します

Option Explicit

Public Sub Sample_2()

  '元々のデータ列数(A列〜B列)
  Const clngColumns As Long = 2
  'Keyの有る列(A列のA列からの列Offset)
  Const clngKey As Long = 0
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngCount As Long
  Dim rngList As Range
  Dim vntKeys As Variant
  Dim lngDelete() As Long
  Dim dicIndex As Object
  Dim strProm As String

  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = ActiveSheet.Cells(1, "A")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'A列データを配列に取得
    vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
  End With
  
  '削除Flagを格納する配列を確保
  ReDim lngDelete(1 To lngRows, 1 To 1)
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  With dicIndex
    For i = 1 To lngRows
      'Dyctionaryに登録が有る場合
      If .Exists(vntKeys(i, 1)) Then
        '削除Flagを立てる
        lngDelete(i, 1) = 1
        '削除行数をカウント
        lngCount = lngCount + 1
      Else
        'Dyctionaryに登録
        .Item(vntKeys(i, 1)) = Empty
      End If
    Next i
  End With

  Set dicIndex = Nothing
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '削除行が有った場合
    If lngCount > 0 Then
      '削除Flagをを出力
      .Offset(1, clngColumns).Resize(lngRows).Value = lngDelete
      '削除FlagをKeyとしてListを整列
      .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
          Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
          Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
          Orientation:=xlTopToBottom, SortMethod:=xlStroke
      '不用行を削除
      .Offset(lngRows - lngCount + 1).Resize(lngCount).EntireRow.Delete
      strProm = lngCount & "行を削除しました"
    Else
      strProm = "重複行は在りません"
    End If
    '復帰用Key列を削除
    .Offset(, clngColumns).Resize(, 2).EntireColumn.Delete
  End With
   
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

0 hits

【66738】重複する行を削除したい ponte 10/10/3(日) 0:37 質問
【66739】Re:重複する行を削除したい ANTON 10/10/3(日) 2:24 回答
【66741】Re:重複する行を削除したい teian 10/10/3(日) 7:59 発言
【66742】Re:重複する行を削除したい kanabun 10/10/3(日) 9:32 発言
【66743】Re:重複する行を削除したい kanabun 10/10/3(日) 9:35 発言
【66744】Re:重複する行を削除したい Hirofumi 10/10/3(日) 11:24 回答
【66748】Re:重複する行を削除したい Hirofumi 10/10/3(日) 15:43 回答
【66749】Re:重複する行を削除したい ponte 10/10/3(日) 17:50 お礼

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