Excel VBA質問箱 IV

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

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


15471 / 76738 ←次へ | 前へ→

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

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

Option Explicit

Public Sub Sample()

  '元々のデータ列数(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 vntData As Variant
  Dim strProm As String

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

  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成(C列に)
    With .Offset(1, clngColumns)
      .Value = 1
      .Resize(lngRows).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, _
          Date:=xlDay, Step:=1, Trend:=False
    End With
    'データをA列で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(, clngKey), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'A列データを配列に取得
    vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
    '復帰用整列Keyを配列に取得
    vntData = .Offset(1, clngColumns).Resize(lngRows + 1).Value
  End With
  
  For i = 2 To lngRows
    '一つ上の値と現在値が同じ場合
    If vntKeys(i - 1, 1) = vntKeys(i, 1) Then
      '復帰用整列KeyをEmptyに
      vntData(i, 1) = Empty
      '削除行数をカウント
      lngCount = lngCount + 1
    End If
  Next i

  With rngList
    '復帰用整列Keyを出力
    .Offset(1, clngColumns).Resize(lngRows).Value = vntData
    '復帰用Keyを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
    '削除行が有った場合
    If lngCount > 0 Then
      '不用行を削除
      .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 お礼

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