Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2644 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【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


	【66738】重複する行を削除したい

ponte - 10/10/3(日) 0:37 -


	引用なし

	パスワード

プログラムでA列の値が重複する行を削除したい（重複が有る場合は一番上の行のデータを残す）と思いますが
どうコーディングすればいいですか．
Excelは2003です．
よろしくお願いいたします．


	【66739】Re:重複する行を削除したい

ANTON - 10/10/3(日) 2:24 -


	引用なし

	パスワード

▼ponte さん：
>プログラムでA列の値が重複する行を削除したい（重複が有る場合は一番上の行のデータを残す）と思いますが
>どうコーディングすればいいですか．
>Excelは2003です．
>よろしくお願いいたします．

こんな感じのマクロを組んでみましたが、ご希望に添えていますか？

ちなみにこのマクロの制限事項としてxlDownを使用していますので、初期値の時点でA列の途中に空白がある場合、その空白部分までしかマクロが実行されません。

A列が何列あるのかわからないのでUntilを使用しましたが、何列かが毎回決まっているならForを使用してもいいと思います。

途中に空白がある場合は、Forを使用しないと難しいように思えます。。。

途中に空白があり、なおかつ何列かわからない場合、ちょっと複雑なマクロになるかもしれません。。。

マクロの説明としましては、A列の最終行一個下にEndという文字を入力することで、Untilの終了条件を定めています。
Untilの終了条件を空白としていないのは、重複した際に消す作業をしているので
消した事によって空白になった部分を終了部分と誤認識させないためです。

Dim HikakuA As Variant, HikakuB As Variant
Dim i As Integer, j As Integer

i = 1 '開始行数の指定

Cells(1, "A").End(xlDown).Offset(1, 0) = "End"

Do Until Cells(i, "A") = "End"
HikakuA = Cells(i, "A")
　　j = i + 1

1　'GoToポイント
　　HikakuB = Cells(j, "A")
　　
　　If HikakuA = HikakuB Then　'重複があった場合の条件式
　　Cells(j, "A") = ""　　　　 'セルに空白を代入
　　End If
　　j = j + 1
　　If j = 100 Then Exit Do '∞ループ回避策
　　
If Cells(j, "A") <> "End" Then　'HikakuBがEndまで到達していない場合の条件式
GoTo 1　'ポイント1まで戻る
End If
　　
i = i + 1

If i = 100 Then Exit Do '∞ループ回避策
Loop

End Sub


	【66741】Re:重複する行を削除したい

teian - 10/10/3(日) 7:59 -


	引用なし

	パスワード

▼ponte さん：
>プログラムでA列の値が重複する行を削除したい（重複が有る場合は一番上の行のデータを残す）と思いますが
>どうコーディングすればいいですか．

以下の手順をコードにしてはいかがでしょう。

１．空いている列を作業列として以下の数式を埋める
　　"=CountIF($A$1:A1,A1)"
２．その列でデータ範囲全体をソートする。
３．１の列において「１」以外のデータをクリアする。
４．後始末として作業列に与えた数式をクリアする。


	【66742】Re:重複する行を削除したい

kanabun - 10/10/3(日) 9:32 -


	引用なし

	パスワード

▼ponte さん：
おじゃまします。

>プログラムでA列の値が重複する行を削除したい（重複が有る場合は一番上の行のデータを残す）

一般機能の「フィルタオプションの設定(Unique:=True)」を
使うのも手かと思います。

フィルタオプションの設定でやるときは、
表の一行目は項目見出しである必要があります。

いちどほんとに重複カットできるか、以下で確認してみましょう

Sub 確認()
　Range("A1", Cells(Rows.Count, 1).End(xlUp)) _
　　.AdvancedFilter xlFilterInPlace, Unique:=True
　MsgBox "OK?"
　ActiveSheet.ShowAllData
End Sub

もし、うまく行ったなら、本番です
本番は表全体を作業用一時シートにコピーしておいてから、
一時シートで抽出したものを元のシートに戻すという手順をとります。

Sub 実行()
　Dim Target As Range, Address1 As String
　Dim oSheet As Worksheet '対象シート
　Dim nSheet As Worksheet '作業用一時シート
　
　'----準備作業用シートに全データコピー
　Set oSheet = ActiveSheet
　With oSheet
　　　Set Target = Range("A1", Cells(Rows.Count, 1).End(xlUp)) _
　　　　　.Resize(, .UsedRange.Columns.Count)
　　　Address1 = Target.Address
　End With
　Set nSheet = Worksheets.Add
　Target.Copy nSheet.Range("A1")
　Target.ClearContents
　
　'--- 作業用シートで重複カット実行
　With nSheet.Range(Address1)
　　　'A列だけを対象にフィルタオプションでUniqueデータとする
　　　.Columns(1).AdvancedFilter xlFilterInPlace, Unique:=True
　　　.Copy
　End With
　
　'---元のシートに貼り付け直す
　Target.Cells(1).PasteSpecial xlPasteValues
　
　'--- 作業用シートの削除
　Application.DisplayAlerts = False
　nSheet.Delete
　Application.DisplayAlerts = True
　
End Sub


	【66743】Re:重複する行を削除したい

kanabun - 10/10/3(日) 9:35 -


	引用なし

	パスワード

あわわ、

↑Range や Cellsのまえのドット(.) が抜けてました m(_ _)m

　'----準備作業用シートに全データコピー
　Set oSheet = ActiveSheet
　With oSheet
　　　Set Target = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)) _
　　　　　.Resize(, .UsedRange.Columns.Count)
　　　Address1 = Target.Address
　End With


	【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


	【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


	【66749】Re:重複する行を削除したい

ponte - 10/10/3(日) 17:50 -


	引用なし

	パスワード

皆様

本当にありがとうございます。
いろいろな方法があり、勉強になりました。
今からいずれも試させていただき、一番しっくり来る方法を選択したいと思います。
また、質問することもあるかと存じますが、その節はよろしくお願いいたします。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2644 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free