エクセルの学校：全文検索：Hyper Estraier： VBA 強制終了

Results of 1 - 1 of about 85 for VBA 強制終了 (0.004 sec.)

vba (14726), 強制終了 (237)

[[20150919135536]]: #score: 16176; @digest: 88ea627c68f91ef7c3945ce10c09de08; @id: 68928; @mdate: 2015-09-20T02:05:49Z; @size: 11628; @type: text/plain; #keywords: kitenrng (164505), colcnt (33605), 様20 (14426), カリ (12979), ーニ (11703), ニン (11028), 構重 (9811), mydic (7000), ン様 (5786), リー (5253), removeall (4996), 万行 (3926), 土) (3441), 2015 (3209), △ (3051), typename (3007), ル数 (2634), nothing (2580), （カ (2440), 分割 (2292), 左側 (1942), 重複 (1710), ● (1664), 白セ (1611), selection (1525), offset (1368), 結構 (1355), screenupdating (1348), セル (1336), columns (1290), scripting (1281), ○ (1274); 『同一行に含まれる重複セルを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万行ということなので、関数にしても、その他のシート上の処理にしてもシート上での個別処理は、いずれにしても結構重いでしょうね。カリーニンさんからアドバイスがある、ジャンプ機能も、適した1つの方策だと思います。 (セル数がセル数ですから、取得可能セル数仕様がどうなっているのか気にはなりますが）これについては、カリーニンさんから、コード作成のお手伝いがあるかと思いますので別案です。結局は領域セル数分（5万行,150列なら750万回)の処理になりますが、書き込み処理すべてをメモリー内で行い、最後に、どさっと転記。しかし、量が量ですから・・・手元に5万行,150列のデータ、各セルはランダムなアルファベットをセットしたものを用意して流してみますとなんと、21秒もかかりました。データ処理に10秒、そのセルへの一括書きこみに10秒。当方のPCは結構性能がいいので、大量データでも秒殺といったことが多いのですがかかりますねぇ、これは。そもそも、そういった処理云々以前に、このデータ、保存するにも結構重いのでは? いつか、ブックが壊れてしまうリスクも高そうです。 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 ...; http://www.excel.studio-kazu.jp/wiki/kazuwiki/201509/20150919135536.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ