[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『同一行に含まれる重複セルを1セルだけ残して左詰め削除する』（いっちゃん）
A B C D E 1 ○ ● △ ○ ▲ 2 ▲ ● ● ● ○ 3 △ ▲ □ ○ □ 4 □ ○ △ ● △
|こうしたい
V
A B C D E 1 ○ ● △ □ ▲ 2 ▲ ● △ □ ○ 3 △ ▲ □ ○ ● 4 □ ○ △ ● ▲
上記のように、同一行に重複データが含まれている表があります。 重複セルの数は一定ではありません。 重複しているデータの内容は複数あります。 すべての行に重複データが含まれているわけではありません。 表の列数は150、行数は50000を超えています。
この状態の表を重複のないセルは残し、
重複しているセルを1セルだけ残して左詰めで削除する必要があります。
VBAまたは関数で、一括処理する方法を教えていただけませんでしょうか。
よろしくお願いいたします。
＜ 使用 Excel：Excel2007、使用 OS：Windows8 ＞
セル範囲に空白のセルはありますか？ （カリーニン） 2015/09/19(土) 14:58
マクロでの考え方です。
空白セルがなにのなら、左側のセルと同じならセルをクリア、 後で空白セルにジャンプして一括削除、という流れで行けると思います。
>空白セルがなにのなら、左側のセルと同じならセルをクリア、 これはループしながら条件分岐することになります。 （カリーニン） 2015/09/19(土) 15:02
ちょっと先走ったレスになりますが。
>>空白セルがなにのなら、左側のセルと同じならセルをクリア、 > これはループしながら条件分岐することになります。
ループするときは右側のセルからループします。 でないと、既に左側のセルと同じということでクリアした場合、 その右側のセルと元々は同じであった場合でも、空白とデータ があるセルとでは内容が違うということでクリアの対象にならな くなるからです。 （カリーニン） 2015/09/19(土) 15:29
A B C D E 1 ○ ● △ ○ △ 2 ▲ ● ● ● ○ 3 △ ▲ □ ○ □ 4 □ ○ △ ● △
↑の場合、一行目はどうしたいですか？
こっち？
1 ○ ● △ ○ △
それともこっち？
1 ○ ● △ ○
（カリーニン） 2015/09/19(土) 15:34
縦の列単位であれば重複の削除機能も利用できるんですが、横の行ですのでね・・・
さらに、５万行ということなので、関数にしても、その他のシート上の処理にしても シート上での個別処理は、いずれにしても結構重いでしょうね。
カリーニンさんからアドバイスがある、ジャンプ機能も、適した１つの方策だと思います。 (セル数がセル数ですから、取得可能セル数仕様がどうなっているのか気にはなりますが）
これについては、カリーニンさんから、コード作成のお手伝いがあるかと思いますので 別案です。結局は領域セル数分（5万行,150列なら750万回)の処理になりますが、書き込み処理すべてを メモリー内で行い、最後に、どさっと転記。
しかし、量が量ですから・・・手元に5万行,150列のデータ、各セルはランダムなアルファベットをセットしたものを用意して 流してみますとなんと、21秒もかかりました。 データ処理に10秒、そのセルへの一括書きこみに10秒。 当方のＰＣは結構性能がいいので、大量データでも秒殺といったことが多いのですが かかりますねぇ、これは。
そもそも、そういった処理云々以前に、このデータ、保存するにも結構重いのでは？ いつか、ブックが壊れてしまうリスクも高そうです。
Sub Sample()
Dim w As Variant
Dim dic As Object
Dim c As Range
Dim r As Range
Dim d As Variant
Dim x As Long
Set dic = CreateObject("scripting.Dictionary") '重複排除作業用辞書
With Range("A1").CurrentRegion
ReDim w(1 To .Rows.Count, 1 To .Columns.Count) 'データ領域の大きさの配列
For Each r In .Rows '領域の各行
dic.RemoveAll
For Each c In r.Cells 'その行の各セル
dic(c.Value) = True '作業用辞書に書きこみ。同じものがあれば上書きされる
Next
x = 0
For Each d In dic '一意化された行のデータを抽出
x = x + 1
w(r.Row, x) = d '配列内に前詰めでセット
Next
Next
End With
Range("A1").CurrentRegion.Value = w '配列から一括書きこみ
End Sub
（β） 2015/09/19(土) 16:32
データ数見てなかったです・・・。
10,000行150列のデータでさえ、私が試しに作ったコード だと1分半越えたので強制終了しました。 強制終了したときは7,000行目あたりだったので、5万行だととても実用に耐えないですね。 なお、私の試しに作ったコードは配列に格納せずに直接セルのデータを削除するものです。 時間かかるの当たり前ですね。
10,000行150列のデータでさえ、作成したブックのサイズが12.4MBなので5万行だともっとすごい サイズになりますね。
これはエクセルではなくデータベース系のアプリケーションに移行した方がいいかもしれないです ね。 （カリーニン） 2015/09/19(土) 17:26
10,000行150列のデータで、セル転記を配列しように変えたら23秒ほどになりました。 単純計算だと、50,000行で2分ほどですね。これでも遅い・・・。
コードは↓です。 選択範囲セルに対して処理を行います。
Sub test()
Dim c As Range
Dim i As Long
Dim j As Long
Dim kitenrng As Range
Dim mydic As Object
Dim ary() As Variant
Dim colcnt As Long
If TypeName(Selection) <> "Range" Then Exit Sub
Set mydic = CreateObject("Scripting.Dictionary")
Set r = Selection
Set kitenrng = r.Resize(1, 1)
ReDim ary(r.Columns.Count - 1, r.Rows.Count - 1)
For i = 1 To r.Rows.Count
colcnt = -1
For j = 1 To r.Columns.Count
If mydic.exists(kitenrng.Offset(i - 1, j - 1).Value) Then
Else
colcnt = colcnt + 1
ary(colcnt, i - 1) = kitenrng.Offset(i - 1, j - 1).Value
mydic.Add kitenrng.Offset(i - 1, j - 1).Value, ""
End If
Next j
mydic.RemoveAll
Next i
r.Clear
r.Value = WorksheetFunction.Transpose(ary)
Erase ary
Application.ScreenUpdating = True
Set kitenrng = Nothing
Set r = Nothing
Set kitenrng = Nothing
Set r = Nothing
Set mydic = Nothing
End Sub
（カリーニン） 2015/09/19(土) 17:40
ジャンプ機能を使った場合のコードは↓です。 セルを直接操作しています。
大サイズのデータでは試してません。 10行×10列程度でしか試してません。
Sub test()
Dim c As Range
Dim i As Integer
Dim j As Integer
Dim kitenrng As Range
If TypeName(Selection) <> "Range" Then Exit Sub
Set r = Selection
Set kitenrng = r.Resize(1, 1)
Application.ScreenUpdating = False
For i = 1 To r.Rows.Count
For j = r.Columns.Count To 1 Step -1
If WorksheetFunction.CountIf(Range(kitenrng.Offset(i - 1, 0), kitenrng.Offset(i - 1, j - 1)), kitenrng.Offset(i - 1, j - 1).Value) > 1 Then kitenrng.Offset(i - 1, j - 1).Delete Shift:=xlToLeft
Next j
Next i
Application.ScreenUpdating = True
Set kitenrng = Nothing
Set r = Nothing
Set mydic = Nothing
End Sub
（カリーニン） 2015/09/19(土) 18:04
↑は違うコードでした。
↓です。元からブランクのセルも削除します。
Sub test()
Dim c As Range
Dim i As Integer
Dim j As Integer
Dim kitenrng As Range
Dim mydic As Object
If TypeName(Selection) <> "Range" Then Exit Sub
Set mydic = CreateObject("Scripting.Dictionary")
Set r = Selection
Set kitenrng = r.Resize(1, 1)
For i = 1 To r.Rows.Count
For j = 1 To r.Columns.Count
If mydic.exists(kitenrng.Offset(i - 1, j - 1).Value) Then
kitenrng.Offset(i - 1, j - 1).Clear
Else
mydic.Add kitenrng.Offset(i - 1, j - 1).Value, ""
End If
Next j
mydic.RemoveAll
Next i
r.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
Application.ScreenUpdating = True
Set kitenrng = Nothing
Set r = Nothing
Set kitenrng = Nothing
Set r = Nothing
Set mydic = Nothing
End Sub
（カリーニン） 2015/09/19(土) 18:07
報告だけです。 当方でテストしたデータと同じものを使って、カリーニンさんの 2015/09/19(土) 17:40 のコードに Dim r As Range を追加して流してみました。 結果、最後の r.Value = WorksheetFunction.Transpose(ary) で Transposeプロパティの取得に失敗して1004エラーになりました。
なので、時間計測はできていません。
（β） 2015/09/19(土) 19:02
10,000行×150列でためしたらエラーにならなかったので 仕様に引っかかったのかもしれないですね。
修正版です。
Sub test2()
Dim r As Range
Dim c As Range
Dim i As Long
Dim j As Long
Dim kitenrng As Range
Dim mydic As Object
Dim ary() As Variant
Dim colcnt As Long
If TypeName(Selection) <> "Range" Then Exit Sub
Set mydic = CreateObject("Scripting.Dictionary")
Set r = Selection
Set kitenrng = r.Resize(1, 1)
ReDim ary(r.Rows.Count - 1, r.Columns.Count - 1)
For i = 1 To r.Rows.Count
colcnt = -1
For j = 1 To r.Columns.Count
If mydic.exists(kitenrng.Offset(i - 1, j - 1).Value) Then
Else
colcnt = colcnt + 1
ary(i - 1, colcnt) = kitenrng.Offset(i - 1, j - 1).Value
mydic.Add kitenrng.Offset(i - 1, j - 1).Value, ""
End If
Next j
mydic.RemoveAll
Next i
r.Clear
r.Value = ary
Erase ary
Application.ScreenUpdating = True
Set kitenrng = Nothing
Set r = Nothing
Set mydic = Nothing
End Sub
（カリーニン） 2015/09/19(土) 19:15
カリーニンさんの Test2 確認しました。 当方の環境で 30秒でした。
（β） 2015/09/19(土) 19:53
確認ありがとうございます。
CPU取り替えたい・・・。 （カリーニン） 2015/09/19(土) 20:48
ご質問に順番にお応えしたいと思います。
カリーニン様 2015/09/19(土) 14:58
セル範囲に空白のセルはありますか？ これはありません。 入力のつど空白セルをジャンプ機能で左詰め削除してあります。
カリーニン様 2015/09/19(土) 15:34
↑の場合、一行目はどうしたいですか？ こっち？ 1 ○ ● △ ○ △ それともこっち？ 1 ○ ● △ ○
こうしたいんです。
1 ○ ● △
β様 2015/09/19(土) 16:32
そもそも、そういった処理云々以前に、このデータ、保存するにも結構重いのでは？ はい。他のソフトが立ち上がっていると1分近くかかることもあります。
いつか、ブックが壊れてしまうリスクも高そうです。 これは懸念材料ですが、実際の使用環境は変更できないので、 あまりにデーターが大きくなってきた場合には分割対応を考えています。
私個人のPCの処理能力はそれなりですが・・・
メモリ：64G
システム：SSDX4 RAID 0
DATA:512GSSDX4 RAID 0
実際に稼働させるPCに望めるスペックは決して多くはありません。
カリーニン様 2015/09/19(土) 17:26
これはエクセルではなくデータベース系のアプリケーションに移行した方がいいかもしれないですね。
アクセスへの移行を考慮しましたが、
セルに格納できる文字数が足りないのです。
mySQL等は実際の業務では実行環境がなく、
操作経験者もいないため採用できません。
現状ではエクセル上でやるしかないのです。
シートを分割して対応できないでしょうか。
引き続き、ご協力をお願いいたします。
（いっちゃん） 2015/09/19(土) 22:14
>こうしたいんです。 >1 ○ ● △
βさんのコードも私のコードもそのようになっています。
>シートを分割して対応できないでしょうか。
これは回答者が決めることではなく、いっちゃんさん(と会社の方) が決めることです。
複数シートにまたがった場合の処理のことをお聞きしているのであれば、 対象シートをどのようにして決めて、その中の対象セル範囲がどうなっているか を明示してください。 （カリーニン） 2015/09/19(土) 23:25
β様のコードもカリーニン様のコードも
希望通りの結果が得られています。
大変ありがとうございました。
複数シートをまたぐ処理につきましては、
実務担当者と相談の上、必要な時期に改めてお尋ねしたいと思います。
短時間で解決できて大変助かりました。
カリーニン様、β様
ありがとうございました。
（いっちゃん） 2015/09/19(土) 23:49
試したわけではないのですが、複数シートへの分割しただけではブックの重さは 変わらないか、逆に重くなる可能性があります。
シートではなく、ブックを分割することも検討してみてください。 ブックを分割しておけば、必要なブックにのみ処理を行うことができます。 （カリーニン） 2015/09/20(日) 11:04
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.