• ベストアンサー
  • 困ってます

セルの値が指定条件なら対象行を削除するマクロ

ボタンクリックでプロシージャーが起動します。 そのマクロの中で以下の2つの処理を追加させたいです。 マクロの記述を教えてください。 A~F列までデータが有ります。 1行目は項目で2行目からデータがあります。 行数は都度相違しますが10,000行はあります。 (1) F列の値は標準で、ここが0の場合その行全体を削除します。 入っている値の例 -1234→削除しない 345→削除しない 12346→削除しない 0→削除する セルの空白はぜったいありません。 (2)-1 E列の値は標準で英数字3ケタです。ところどころ空白があります。 E列の値が先頭7B以外は行全体を削除します。 7B1→削除しない 7B2→削除しない 7BW→削除しない 77C→削除 47B→削除 空白→削除 F列を優先なのでE列が7Bで始まっている行でも F列が0なら削除となります。 (2)-2 (2)-1と同じでE列の値は標準で英数字3ケタです。 ところどころ空白があります。 E列の値が 先頭 7Bと72以外 又は CとDと7B以外は 行全体を削除します。 のように(2)-1のように1条件ではなく2~複数になる。 それが1文字の場合、2文字の場合、3文字全部の場合がある F列を優先なのは(2)-1と同じです。 条件例 ・Cと73以外 ・CとFと72以外 ・Gと7Vと8D以外 ・Gと88と8D5以外 以下の記述ですが、(1)は思ったとうり動作しましたが ●の部分が分かりません。 現在の記述では7BB以外は全部行削除されてしまいます。 (2)-1と(2)-2の対応のために 記述内で(2)-1と(2)-2を 書き換える事が出来るような記述にしたいです。 あと凄く処理が遅いので高速化もしたいです。 よろしくお願いします。 Sub test01() 'A~K列のデータにて 'E,F,H,I,K列を列削除する Columns("E:F").Select Selection.Delete Shift:=xlToLeft Columns("F:G").Select Selection.Delete Shift:=xlToLeft Columns("G:G").Select Selection.Delete Shift:=xlToLeft 'データがA~F列になりました。 With ActiveSheet 'アクティブなシートについて x = .UsedRange.Cells(.UsedRange.Count).Row 'xに最終行を取得 For i = x To 2 Step -1 '最終行から2行目まで下から順に 'F列が"0"だったらその行を削除 If .Cells(i, 6) = 0 Then .Rows(i).Delete Next '繰り返し End With With ActiveSheet 'アクティブなシートについて x = .UsedRange.Cells(.UsedRange.Count).Row 'xに最終行を取得 For i = x To 2 Step -1 '最終行から2行目まで下から順に 'E列の値の先頭文字が"7B"でなかったら削除(空白の場合も削除) ●If .Cells(i, 5) <> "7BB" Then .Rows(i).Delete Next '繰り返し End With End Sub

共感・応援の気持ちを伝えよう!

  • 回答数10
  • 閲覧数2704
  • ありがとう数10

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.7

おはよう。 二日酔いのmerlionXXです。 見直してみました。 わたしのケアレスミスでした。 下から5行目の .Range("A2:F" & j).Value = myW で変数を間違えてます。 Layyさんがご指摘のとおり、j ではなく n にしなければいけません。 .Range("A2:F" & n).Value = myW に訂正します。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございます。 .Range("A2:F" & n).Value = myW で思ったとうり動いて今日はたくさん処理できて 助かりました。 もう22:24。 あとひとふんばりです。

質問者からの補足

あけましておめでとうございます。 今年もよろしくお願いします。 今日は仕事です。10日も仕事です。(T_T) test02は If .Cells(i, 6) = 0 Then .Rows(i).Delete 'F列が"0"だったらその行を削除 Else 'F列が"0"でなかったら If Left(.Cells(i, 5), 2) <> "7B" Then 'E列の値の先頭文字が"7B"でなかったら .Rows(i).Delete '削除(空白の場合も削除) test03は If .Cells(i, 6) = 0 Then .Rows(i).Delete 'F列が"0"だったらその行を削除 Else 'F列が"0"でなかったら 'E列の値先頭がKとE、先頭2文字が72以外は行削除する If Left(.Cells(i, 5), 1) <> "K" And Left(.Cells(i, 5), 1) <> "E" And Left(.Cells(i, 5), 2) <> 72 Then 'E列判定(下記参照) .Rows(i).Delete '削除(空白の場合も削除) と条件の指定の部分は双方<>です。 test04はtest03の高速型で 'F列が"0"だったらその行を削除 If myV(i, 6) <> 0 Then '●E列の値先頭がKとE、先頭2文字が72以外は行削除する If Left(myV(i, 5), 1) = "K" Or Left(myV(i, 5), 1) = "E" Or Left(myV(i, 5), 2) = 72 Then と条件の指定の部分は=です。 02と03は <>ですが 04は = です。 02の高速型を作成する場合は 'F列が"0"だったらその行を削除 If myV(i, 6) <> 0 Then '●E列の値の先頭文字が"7B"でなかったら If Left(myV(i, 5), 1) = "7B" Or Left(myV(i, 5), 2) それとも If Left(myV(i, 5), 1) = 7B Then でいいのでしょうか? あと高速型test04の方で 02,03に有る 「E列が空白の場合も行削除」は どの部分になるのでしょうか? (コメントを入れたいのですがよく分かりません。) 申し訳ありませんよろしくお願いします。

関連するQ&A

  • マクロセルの値によってセルの色を消す

    エクセル2013です。 セルの値が0又は空白の場合でそのセルが色塗りされていたら色を消す というマクロをを作成しました。 ただ700行55列では処理が遅いです。 Sub 色消() '成功 Dim 最終行 Dim 最終列 Dim 対象セル As Range 最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得 最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得 For Each 対象セル In Range(Cells(10, 17), Cells(最終行, 最終列)) If 対象セル.Value = 0 Or 対象セル = "" Then 対象セル.Interior.ColorIndex = 0 End If Next 対象セル End Sub 対象範囲から対象セルを全部見つけて一括処理すれば早いのではと 以下のマクロを作成してみましたが Set 対象範囲 = Cells.Find(What:=0 Or "", LookIn:=xlValues, LookAt:=xlWhole) で構文ERRです。 どこを直せばいいのでしょうか? よろしくお願いします。 Sub 色消2() '2014/8/4 '失敗 Dim 対象範囲 Dim 最終行 Dim 最終列 最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得 最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得 対象範囲 = Range(Cells(10, 17), Cells(最終行, 最終列)) Set 対象範囲 = Cells.Find(What:=0 Or "", LookIn:=xlValues, LookAt:=xlWhole) If Not 対象範囲 Is Nothing Then 対象範囲.Interior.ColorIndex = 0 End If End Sub

  • 条件にて行削除をするをマクロで高速化したい

    シート(最初)のA,B,C列を連結した値と シート(残)のA,B,C列を連結した値を照合させ 同じ値の場合は シート(残)の該当行を削除です。 シート(最初)は6,182行 シート(残)は7,561行です。 VLookupを使って処理時間5分です。 VLookupを使わない記述で25分です。 20,000行位のデータを処理したいのですが時間が不安です。 別スレで 「VLookupで処理3分をdictionaryオブジェクトで1秒以内にする方法」を 教えていただきましたが、流用ができません。 シート(残)内にもシート(最初)内にも重複行はありません。 私の記述は「F列を検索用に使用」となっていて F列にデータがある場合、都度記述を書換えないと 使えないので、そこも対応したいです。 照合させる値はA,B,Cの連結値というのは変わらないのですが データがある範囲は都度変化する為です。 ・A&#65374;E列とかA&#65374;H列とか ・シート残はA&#65374;E列、シート最初はA&#65374;G列とか 記述そのものを教えてください。よろしくお願いします。 Sub 自動重複削除F列使用() 'シート(最初)のA,B,C列とシート(残)のA,B,C列が一致した行は 'シート残の行を削除 'F列を検索値として使用。 Dim Line As Long Dim LastRow As Long Dim myRange As Range Dim Flag 'シート「最初」のF1に、A,B,C列を結合した値を転記 With Sheets("最初") Set myRange = .Range("F2:F" & .Cells(Rows.Count, "A").End(xlUp).Row) .Range("F2").FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]" 'シート「最初」のF2からデータのあるところまで 'F1の規則でデータ貼付 .Range("F2").AutoFill Destination:=myRange End With 'シート「残」のF1に、A,B,C列を結合した値を転記 Sheets("残").Select LastRow = Cells(Rows.Count, "A").End(xlUp).Row Range("F2").FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]" 'シート「最初」のF2からデータのあるところまで 'F1の規則でデータ貼付 Range("F2").AutoFill Destination:=Range("F2:F" & LastRow) On Error Resume Next '双方のシートのF列を照合させ、ヒットした行は 'シート「残」から行削除をする For Line = LastRow To 2 Step -1 Flag = WorksheetFunction.VLookup(Cells(Line, 6).Value, myRange, 1, 0) If Err.Number = 0 Then Rows(Line).Delete xlUp Else Err.Clear End If Next Line '検索に使用したF列を削除 Sheets("残").Select Columns("F:F").Select Selection.Delete Shift:=xlToLeft Sheets("最初").Select Columns("F:F").Select Selection.Delete Shift:=xlToLeft Sheets("残").Select Range("A1").Select End Sub ●別方法 Sub 自動重複行削除F列未使用超遅() 'VLOOKUP無 'シート(最初)のA,B,C列とシート(残)の 'A,B,C列が一致した行はシート(残)の行を削除 Dim ws1, ws2 As Worksheet Dim i, j As Long Set ws1 = Worksheets("最初") Set ws2 = Worksheets("残") For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row For j = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If ws1.Cells(i, 1) = ws2.Cells(j, 1) And ws1.Cells(i, 2) = ws2.Cells(j, 2) And _ ws1.Cells(i, 3) = ws2.Cells(j, 3) Then ws2.Rows(j).Delete (xlUp) End

  • セルの値が同じ行を条件に従って行削除するマクロ

    A&#65374;E列までデータがあり 行数は約30,000行あります。 A列は半角英数字と-で桁数は11桁又は14桁です。 数字のみもあれば数字と英字の組み合わせもあります。 (英字はどこの桁にあるか何個あるかは不規則です) 例 ABCD123456789X 124345678901234 55555-55555 ABC12345DEF678 E列には半角の 1 か 2 しかありません。 A列が同じ値の行を検出して重複している行は1行だけ残して 後は行削除をしたいです。 行削除はE列の値によって判定したいです。 重複行は1つの値に対して何行あるか不明です。 30,000行のうち、重複行を削除すると10,000行くらいになる予定です。 (1)重複行にてE列の値が1だけの場合    どれでもいいので1行残して残りは行削除 (2)重複行にてE列の値が2だけの場合   どれでもいいので1行残して残りは行削除 (3)重複行にてE列の値が1も2もある場合   E列の値が2の行をどれでもいいので1行残して残りは削除 例 (1) 1234567890XXXX-1 1234567890XXXX-1 1234567890XXXX-1 ↓ 1234567890XXXX-1 (2) 123ABCDE901234-2 123ABCDE901234-2 ↓ 123ABCDE901234-2 (3) 12345678901234-1 12345678901234-2 ↓ 12345678901234-2 ABC45678901234-1 ABC45678901234-2 ABC45678901234-1 ABC45678901234-2 ↓ ABC45678901234-2 手作業では5時間かかりましたがミスだらけです。 まだ数ファイル残っており手作業では厳しいのでマクロを 作成したいのですが、どう記述していのかまったく検討が付きません。 どうかよろしくお願いします。

その他の回答 (9)

  • 回答No.10

今日の補足みました。 これ、わたしが教えたの? > その状態のまま > Sub エクセル6ファイル取込()を再度走らせます。 この段階で、Sheets("現在在庫")のセルがクリアされますよ。 > MsgBox "抽出した6ファイル用意されていますか?" これでは「はい」しか選択できませんね? だから、自動的に Sub エクセル6ファイル選択 がCallされますね。 ところが、Static を使ってるから、変数myCntはこのプロシージャーが終了しても保持されたままです。(6になってるはず) したがって、 If myCnt >= 6 Then で MsgBox "6個のBOOKの転記が終了してます。" となり Exit Sub でマクロが終了します。 エクセル6ファイル取込()を再度走らせるとは、そのBOOKを終了せずに、同じようなことをまた続けたいってこと? それなら Sub エクセル6ファイル選択02() 'エクセルファイルを選択します。6回行います。 '1番目のプロシージャーでCallされます。2回目に走ります。 Dim ans As Boolean Static myCnt As Integer If myCnt >= 6 Then MsgBox "6個のBOOKの転記が終了してます。" myCnt = 0 '*ここでカウントを初期化 Exit Sub End If ans = Application.Dialogs(xlDialogOpen).Show If ans Then myCnt = myCnt + 1 Call 在庫データ6ファイル転記(ActiveWorkbook, myCnt) End If End Sub としたらどうなるかな? 試してないから責任もてませんが。(こんなことやったことないよ)

共感・感謝の気持ちを伝えよう!

質問者からのお礼

教えていただいたとうりにしてみました。 やはり 自動的に Sub エクセル6ファイル選択 がCallされ MsgBox "6個のBOOKの転記が終了してます。" となり Exit Sub でマクロが終了 でマクロ終了後に再度同じマクロでの処理はできませんでした。 このスレと違う質問ですのでもう閉じます。 もともと別スレで教えていただいた時に 最初から継続したいという要求はしていませんし 1回閉じて、再立ち上げすれば機能上問題は ないです。 理屈的に継続処理が出来ないのがわかったので いいです。 (私の改造ミスならして指摘していただきたかった。) お手数をかけてすいませんでした。 どうもありがとうございました。

質問者からの補足

はいすいません。 http://okwave.jp/qa/q6327202.html QNo.6327202 2010-11-18 09:44:57 ANo.1 2010-11-18 11:37:32 で教えていただきました。 でそれを Sub GetBook() ↓ Sub エクセル6ファイル選択() Sub GetData(ByRef wb As Object, ByVal myCnt As Integer) ↓ Sub 在庫データ6ファイル転記(ByRef wb As Object, ByVal myCnt As Integer) にして5回を6回に改造しました。 また冒頭に 別スレで教えていただいた物を改造した Sub エクセル6ファイル取込() としてくっつけました。 最初は改造が間違っていると思いましたが 最初に教えていただいた↓の記述だけで行っても、 同じく2回目は取り込みが出来ませんでしたので 質問してみました。m(__)m 実際はそういう運用はしないのですが 暮れにたまたまそういう事をした時に疑問に 思ったままでしたので。m(__)m 改造前↓ Sub GetBook() Dim ans As Boolean Static myCnt As Integer If myCnt >= 5 Then MsgBox "5個のBOOKの転記が終了してます。" Exit Sub End If ans = Application.Dialogs(xlDialogOpen).Show If ans Then myCnt = myCnt + 1 Call GetData(ActiveWorkbook, myCnt) End If End Sub ---- Sub GetData(ByRef wb As Object, ByVal myCnt As Integer) Dim x As Long MsgBox wb.Name & "からデータを取得します。", vbInformation, myCnt & "回目ですね。" With wb.ActiveSheet x = .Cells(Rows.Count, "A").End(xlUp).Row If myCnt = 1 Then .Rows("1:" & x).Copy ThisWorkbook.Sheets("Sheet1").Range("A1") Else .Rows("2:" & x).Copy ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1) End If End With wb.Close (False) MsgBox myCnt & "回目の転記が完了" If myCnt < 5 Then Call GetBook Else MsgBox "5個のBOOKの転記が終了しました。" Call 編集 End If End Sub

  • 回答No.9

まだ松の内だから、明けましておめでとうございます。 1月は5日から仕事です。今日はお休みですが。 ANo7の補足を見ました。 > 02と03は <>ですが > 04は = です。 はい、その通り。 理由は分かりますね? 前にも説明したように高速化させるため、ワークシート上で不要行を削除するのはやめて、残す行のデータだけを2次元配列に取り込むようにしたからです。 trst02を同じように高速化させるなら、 「E列の値の先頭文字が"7B"でなかったら、E列が空白の場合も含め、その行を削除する」ということは、逆にE列の先頭2文字が"7B"だけを2次元配列に取り込めばいいってことだよね。 つまり、 If Left(myV(i, 5), 2) = “7B” Then で、OKです。 > If Left(myV(i, 5), 1) = 7B Then  ではだめです。 よく見比べてください。 > あと高速型test04の方で02,03に有る「E列が空白の場合も行削除」はどの部分になるのでしょうか? もう説明の必要もないと思いますが、データを残す条件だけを指定すれば、わざわざ「空白の場合も行削除」を指示しなくても削除されるってわけです。 以上、今年最初のこども電話相談室でした。(笑)

共感・感謝の気持ちを伝えよう!

質問者からのお礼

お礼が遅れました。 いつもありがとうございます。 >あと高速型test04の方で >02,03に有る 「E列が空白の場合も行削除」は >どの部分になるのでしょうか? >(コメントを入れたいのですがよく分かりません。) 要求事項を処理している部分に 無理にコメントをいれようとして 馬鹿言ってました。m(__)m すいません。 教えていただいたとうりでした。

質問者からの補足

すいません。閉じる前に。もう1回。 merlionXXさんにしか聞けない事なのでm(__)m 最初の質問にて >ボタンクリックでプロシージャーが起動します。 >そのマクロの中で以下の2つの処理を追加 このマクロというのはmerlionXXさんに教えていただいた物を 改造したものです。 Sub エクセル6ファイル取込() 'これが一番最初に走ります。 Sheets("現在在庫").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select MsgBox "抽出した6ファイル用意されていますか?" Call エクセル6ファイル選択 End Sub ------- Sub エクセル6ファイル選択() 'エクセルファイルを選択します。6回行います。 '1番目のプロシージャーでCallされます。2回目に走ります。 Dim ans As Boolean Static myCnt As Integer If myCnt >= 6 Then MsgBox "6個のBOOKの転記が終了してます。" Exit Sub End If ans = Application.Dialogs(xlDialogOpen).Show If ans Then myCnt = myCnt + 1 Call 在庫データ6ファイル転記(ActiveWorkbook, myCnt) End If End Sub ---- Sub 在庫データ6ファイル転記(ByRef wb As Object, ByVal myCnt As Integer) '選択したファイルをシート「現在在庫」に転記します。 '1回目は1行目から、2~6回目は2行目からです。 '2番目のプロシージャーでCallされます。3回目に走ります。 Dim x As Long MsgBox wb.Name & "からデータを取得します。", vbInformation, myCnt & "回目ですね。" With wb.ActiveSheet x = .Cells(Rows.Count, "A").End(xlUp).Row If myCnt = 1 Then .Rows("1:" & x).Copy ThisWorkbook.Sheets("現在在庫").Range("A1") Else .Rows("2:" & x).Copy ThisWorkbook.Sheets("現在在庫").Cells(Rows.Count, "A").End(xlUp).Offset(1) End If End With wb.Close (False) MsgBox myCnt & "回目の転記が完了" If myCnt < 6 Then '次のファイルを選択する為2番目に走ったプロシージャーをCallします。 Call エクセル6ファイル選択 Else MsgBox "6個のBOOKの転記が終了しました。" Call ●このスレで教えていただいたマクロ(test04) End If End Sub これでシート「現在在庫」に取り込んだデータが このスレで教えていただいたマクロ(test04)で編集された状態で 完了しています。 その状態のまま Sub エクセル6ファイル取込()を再度走らせます。 ↓ MsgBox "抽出した6ファイル用意されていますか?" ↓ 「はい」 ↓ MsgBox "6個のBOOKの転記が終了してます。" となり先ほど編集されたシート「現在在庫」のデータが 全て削除されて終わってしまい取込ファイル選択画面になりません。 一度このエクセルを閉じて再度開いて Sub エクセル6ファイル取込()を起動されば大丈夫です。 実用上問題ないのですがこの原因が分かりません。 通常マクロの処理後、また同じマクロを起動できます。 (処理内容によってはそれをやるとデータは目茶苦茶になりますが) 今回は処理後のシートを別のBOOKにコピペして、 引き続き別データを同じように処理しようとしてマクロを起動したら 出来なかったので疑問が。 暮れからこの件が頭に合ってそのうち次の依頼が大量に来て。 説明が難しいので意味が通じなかったらスルーしてください。 いろいろありがとうございました。

  • 回答No.8
  • layy
  • ベストアンサー率23% (292/1222)

Application.ScreenUpdating = False Application.ScreenUpdating = TRUE この機能は覚えておくこと。 表示→カーソル移動→判定→物理的に消す→(消えた状態を)表示→カーソル移動 これを繰り返すだけで結構時間かかります。 (チカチカします。) 何でもかんでもこれ使うかというわけでなくて、 処理中に何が起きているか見なくてもいいレベルになったらこれを記載することでしょう。 あと、 右の列のどっかに「削除対象行は=消の文字」としてあげたら、 あとはDELETEのコマンド発行しなくても、 並べ替えなりフィルタで不要行削除された状態と同じものは実現できるので、 実際にはそちらのが処理がもっと早かったかもしれません。 ゆっくり休んでください。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

いろいろとありがとうございました。 年末は助かりました。

  • 回答No.6
  • layy
  • ベストアンサー率23% (292/1222)

.Range("A2:F" & j).Value = myW のjの値が6になっているからでは?。 "A2:F6"分しか貼り付けていない。 貼り付け用に残っているのはn行もあるから、 .Range("A2:F" & n).Value = myW かな?。 あとは本人の確認待ちで。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございます。 ご指摘のしゅうせいで思ったとおり 動きました。 おかげで助かりました。 まだ、仕事終われませんが.....

  • 回答No.5

> 03は300行残りました。 > 04は4行しか残りません。 それは困った! これからXmasEveのパーティなんです。もういかなくっちゃ。ごめん。 とりあえずTEST03でしのいでいてください。 あと気づいたことがとがあったら教えてください。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

お礼が遅れました。 ありがとうございました。

質問者からの補足

謝らないでください。 お願いしているのは私ですので。 全国的にクリスマスイヴですから。 明日も仕事なので(26日~1月5日まで11連休) 今日もがんばります。 楽しいパーティを。 すいません。4行ではなく6行でした。 残るべき対象データとなる300行の上から6行目だけが 残るようです。 .Range("A2:F" & x).ClearContents これでデーターが全部消えて .Range("A2:F" & j).Value = myW これで条件に該当して配列に取り込まれた のが貼り付くのですよね。 という事は配列に取り込む時に 6行と制限しているのか 配列には300行分取り込んだけど 貼り付ける時に6行までと なっているのかな? そもそももっと違うのかな?

  • 回答No.4

> はい。そのとうりです。 > 私のPCを見られているみたいです。 そうじゃなくて、普通は英数のデータってたいてい半角でしょ? かわいい、かわいいgx9wxちゃんは普通じゃないと言われるとそれまでなんだけど、コードを書くに当たって、半角か全角か、あるいは混在するのか、それによって書き方は変わるんじゃないかぐらいは想像できるよね? だから質問の時には手を抜かず、ちゃんと書いてほしいのです。 > ですが、やはり2~3分は待たないといけません。 以前のはどれくらいかかってました? 無駄に二回ループしてたからもっとかかったんじゃないかな。 でもこんな二回ループ、2007年にわたしが書いてたんだ・・・・。 では高速化した(つもりの)コードです。 高速化の秘訣は、 一番時間のかかる大量の行削除はしない。 セルとデータのやりとりは極力減らす。 だから対象範囲を一旦、二次元配列に取り込んじゃう。 データ処理は配列内で完結させる。(行が削除されたような形のデータにしてしまう。) シートをクリアして一度に貼り付ける。 な~んて知ったかぶりして、ぜんぜん早くなってなかったらお笑いですね。 以下のコードでどれくらいかかるか教えてください。 複数条件の判定方法が逆になってますから注意してください。 あそうだ、gx9wxちゃん、Merry Xmas ! Sub test04() 'Test03の高速化   Dim myV, myW   Dim x As Long, i As Long, n As Long, j As Long   Application.ScreenUpdating = False   With ActiveSheet     .Range("E:F,H:I,K:K").Delete Shift:=xlToLeft     x = .UsedRange.Cells(.UsedRange.Count).Row     myV = .Range("A2:F" & x).Value     ReDim myW(1 To x - 1, 1 To 6)     For i = 1 To x - 1       If myV(i, 6) <> 0 Then         If Left(myV(i, 5), 1) = "C" Or Left(myV(i, 5), 1) = "F" Or Left(myV(i, 5), 2) = 72 Then           n = n + 1           For j = 1 To 6             myW(n, j) = myV(i, j)           Next j         End If       End If     Next i     Application.Calculation = xlCalculationManual     .Range("A2:F" & x).ClearContents     .Range("A2:F" & j).Value = myW   End With   Application.Calculation = xlCalculationAutomatic   Application.ScreenUpdating = True End Sub

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございます。 1秒かかりませんでした。 ですが 同じデータで行った場合 10,000行のうち300行が残るはずで 03は300行残りました。 04は4行しか残りません。 今見ていますが????です。

質問者からの補足

>以前のはどれくらいかかってました? >無駄に二回ループしてたからもっとかかったんじゃないかな。 それがあまり変わりません。 私の記述では7BB以外は全部削除ですから その辺も関係しているかも? >でもこんな二回ループ、2007年にわたしが書いてたんだ・・・・。 すいません。2回ループにしたのは私です。 merlionXXさんが他に方に回答なさったのは (1)の方だけでそれを今回用に書き換えて、 さらに同じ処理だから、 もう1回同じ記述を貼り付けたのです。 2回だと遅くなるのはわかっていましたが VLOOKUPの時に、 式を貼付し出た値を値貼付する方法より 自作の2回ループの方が速かった事もあり 場合によってはLoopでも速かった時もあったので 挑戦したのですが、駄目でした。 (VLOOKUPはその後 例のdictionaryオブジェクトで秒速以下になりましたが) >だから質問の時には手を抜かず、 >ちゃんと書いてほしいのです。 手は抜いてないのですが、そこまで気がつかないのです。 すいません。別スレッドでは半角と書いてました。 今回はなぜ抜けたのかな? はい。Merry Xmas ! イブは会社で過ごし、クリスマスを会社で向かえたらどうしよう.....

  • 回答No.3
  • layy
  • ベストアンサー率23% (292/1222)

単純に考えると、 10000行あるデータを条件1で検証し、条件2でまた検証するとなると20000行のデータを操作していることになっているので遅い。2条件から4条件に増やすと倍遅くなるでしょう。 1行分操作するときに、条件1に合えばL列に〇、合わなければL列に×、条件2に合えばM列に〇、合わなければM列に×、こんな感じでL列が〇でM列が〇なら削除だ、ということで10000行まで行えば操作した行は少なくなり、処理早くなると考えられます。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございます。 条件1は常に同じ条件です。 条件2は今回はE列の3文字にて 先頭から7B以外だったらその行は削除です。 ただ条件2に関してはユーザー要求によって相違します。 例えば 今回は ・先頭から2文字が7Bだけ残してあとは削除 次回は ・先頭がC と 先頭が D と先頭から2文字が76  を残してあとは削除 その次は ・先頭がWと先頭から2文字が8Sと7G6  を残してあとは削除 という感じです。 よって条件2の所は要求に応じて 簡単に書き換えが可能な記述 にしたいです。 アドバイスしていただいた内容を 完全に理解できないのですが こんな感じでいいのでしょうか? L,M列に判定結果を転記し その値から行削除を命令する?。 (イメージなのでこのままでは思ったとうりに処理は  されないのは承知してます。  これ以上は作れなかったです。(泣))   Sub 行削除() 行 = 2 Do If Cells(行, 1).Value = "" Then Exit Do If Cells(行, 6).Value = 0 Then Cells(行, 12).Value = "消" If Cells(行, 5).Value <> "7BB" Then Cells(行, 13).Value = "消" End If End If 行 = 行 + 1 Loop With ActiveSheet x = .UsedRange.Cells(.UsedRange.Count).Row For i = x To 2 Step -1 If .Cells(i, 12) = "消" Then .Rows(i).Delete Next End With End Sub

  • 回答No.2

> A~F列までデータが有ります。 とお書きですが、提示されたコードを見ると、'E,F,H,I,K列を列削除した結果、A~F列のデータになったようです。 そういう理解でいいのですね? 普通はそう言葉で書きますよ。 また、アルファベットや数字を全角でお書きですが、実際のデータは半角なんじゃないですか? その前提で書かれたコードを修正すると以下のようになります。 Sub test02() '(2)-1です。   Application.ScreenUpdating = False   With ActiveSheet 'アクティブなシートについて     .Range("E:F,H:I,K:K").Delete Shift:=xlToLeft 'E,F,H,I,K列を列削除する     x = .UsedRange.Cells(.UsedRange.Count).Row 'xに最終行を取得     For i = x To 2 Step -1 '最終行から2行目まで下から順に       If .Cells(i, 6) = 0 Then         .Rows(i).Delete 'F列が"0"だったらその行を削除       Else 'F列が"0"でなかったら         If Left(.Cells(i, 5), 2) <> "7B" Then 'E列の値の先頭文字が"7B"でなかったら           .Rows(i).Delete '削除(空白の場合も削除)         End If       End If     Next '繰り返し   End With   Application.ScreenUpdating = True End Sub Sub test03() '(2)-2です。   Application.ScreenUpdating = False   With ActiveSheet 'アクティブなシートについて     .Range("E:F,H:I,K:K").Delete Shift:=xlToLeft 'E,F,H,I,K列を列削除する     x = .UsedRange.Cells(.UsedRange.Count).Row 'xに最終行を取得     For i = x To 2 Step -1 '最終行から2行目まで下から順に       If .Cells(i, 6) = 0 Then         .Rows(i).Delete 'F列が"0"だったらその行を削除       Else 'F列が"0"でなかったら         If Left(.Cells(i, 5), 1) <> "C" And Left(.Cells(i, 5), 1) <> "F" And Left(.Cells(i, 5), 2) <> 72 Then 'E列判定(下記参照)           .Rows(i).Delete '削除(空白の場合も削除)         End If       End If     Next '繰り返し   End With   Application.ScreenUpdating = True End Sub 'E列判定の条件例 '・Cと73以外 左の先頭1文字がCでなく、かつ先頭2文字が73でないという意味ですか? ならば If Left(.Cells(i, 5), 1) <> "C" And Left(.Cells(i, 5), 2) <> 73 Then '・CとFと72以外 If Left(.Cells(i, 5), 1) <> "C" And Left(.Cells(i, 5), 1) <> "F" And Left(.Cells(i, 5), 2) <> 72 Then あとはご自分でもわかりますね。 データ量が多いから時間はかかるでしょうね。 配列に取り込めは高速化出来ますが、まずは上記の理解でいいかどうかを確認します。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

こんにちは。 merlionXXさんに過去に教えていただいた 数々のマクロを書き換えて合体して 最後までやり遂げようと思いましたが ギブアップです。 今回提示しました記述はmerlionXXさんが 2007年ぐらいに他の方に回答した物を 持ち出して書き換えたのですが、 これ以上は無理でした。 >> A~F列までデータが有ります。 >とお書きですが、提示されたコードを見ると、 >'E,F,H,I,K列を列削除した結果、A~F列のデータになったようです。 >そういう理解でいいのですね? >普通はそう言葉で書きますよ。 はい。そのとうりです。 やはり私は普通ではないのかな。 >また、アルファベットや数字を全角でお書きですが、 >実際のデータは半角なんじゃないですか? はい。そのとうりです。 私のPCを見られているみたいです。 >あとはご自分でもわかりますね。 はっきり「はい」といえないが辛いです。(泣) 一応、例であげた以外のパターン用に 教えていただいた物を書き換えて行いましたら思ったとおりに 結果が変化しましたので条件変更時の変更部分については 理解できていると思います。 >データ量が多いから時間はかかるでしょうね。 はい。02も03も思ったように動きました。 また03は前述のとうり書き換えても思ったように 動きました。 ですが、やはり2~3分は待たないといけません。 どうもありがとうございました。

質問者からの補足

ちょっと不安です。 >'・CとFと72以外 >If Left(.Cells(i, 5), 1) <> "C" And Left(.Cells(i, 5), 1) <> "F" And Left(.Cells(i, 5), 2) <> 72 Then ・CとFと72と8D5以外 If Left(.Cells(i, 5), 1) <> "C" And Left(.Cells(i, 5), 1) <> "F" And Left(.Cells(i, 5), 2) <> 72 Then And Left(.Cells(i, 5), 3) <> 8D5 Then でいいのでしょうか? E列は3ケタか空白なので 8D5という条件はピンポイントで指定なので = "8D5" Then の方がいいのでしょうか? その場合はLeftはいれず If Left(.Cells(i, 5), 1) <> "C" And Left(.Cells(i, 5), 1) <> "F" And Left(.Cells(i, 5), 2) <> 72 Then And (.Cells(i, 5) = "8D5" Then でいいのでしょうか?

  • 回答No.1
  • layy
  • ベストアンサー率23% (292/1222)

最初に列削除してますが 条件1の判定結果をL列に 条件2-1の判定結果をM列に 条件2-2の判定結果をN列に 最終的に削除するかの判定結果をO列に まずはここまでやって判定の妥当性を確認します。 すべての行に判定でき、問題なかったらO列をみて削除 随時削除、再描画していることが遅くしていると思います。 処理経過を表示させないコマンドあり、参考。 先頭1文字、2文字の文字列判定はLEFT関数使います。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございました。 >まずはここまでやって判定の妥当性を確認 難しいです。すいません。 >処理経過を表示させないコマンドあり、参考。 よく皆さんにアドバイスされてます。 過去の例だとそれでは早くなりませんでした。 今回ははやくなるのでしょうか。 >先頭1文字、2文字の文字列判定はLEFT関数使います。 その関数での条件付けがよく分かりません。 お手数をおかけいたしました。

関連するQ&A

  • エクセルマクロでの行削除の方法について

    エクセルマクロを使用しての行削除の方法についてお伺いします。 現在業務でエクセルに画像内の文字データを入力しています。 入力データは列ごとに半角全角のきまりがあり、 データが入力された行列以外はすべて削除しそれをCSVで保存という流れになっているのですが、 今のところ関数を入れて半角全角チェックをし、それが済んだあとに、 実際のデータ部分以外の箇所をすべて削除し保存しています。 調べたら半角全角はvbNarrowとvbWideという関数があると知り、 列については、特定位置から始まるのでマクロの記録で対応できています(列項目は予め数が決まっていますので)。 ただ、行については画像にどれだけデータがあるかで開始位置が変わってきます。 ***以下は試したマクロ記録です。*** Rows("9:9").Select→何も知らずに「"9:9"」の所で"開始位置の変数:開始位置の変数"としエラーで迷ってます。 Range(Selection, Selection.End(xlDown)).Select Selection.Delete Shift:=xlUp Columns("F:F").Select Range(Selection, Selection.End(xlToRight)).Select Selection.Delete Shift:=xlToLeft 不特定の行から最終行までを選択削除する方法をご存じの方がいましたらご教授お願いいたします。 上記のマクロ使用環境はExcel2003です。

  • エクセルマクロでA欄に値がある行までのC列の範囲を指定したい。?

    エクセルマクロでA欄に値がある行までのC列の範囲を指定したい。? ●エクセルマクロのVBAで次のように記述しています。 Range("C2").FormulaR1C1 = "=VLOOKUP(LEFT(RC[-2],4),C[-2]:C[-1],2,FALSE)" Range("C2").Select Selection.AutoFill Destination:=Range("C2:C148"), Type:=xlFillDefault A列に文字が入っている最終行は A148なので、C2: C148 の範囲にオートフィルで貼り付けるように しています。 しかし、A列に文字が入っている最終行は、変動します。 なお、貼り付ける範囲はいつでも C2から始まります。 A列に文字が入っている最終行が A200であれば、C2: C200の範囲、 A列に文字が入っている最終行が A321であれば、C2: C321の範囲といったように、 C2の値を貼り付ける範囲を設定したいと思っています。 ●そこで、次のように記入してみました。 With Worksheets(2) Dim lRow As Long, lRow = .Cells(Rows.Count, 1).End(xlUp).Row Range("C1").Formula = "名称" Range("C2").FormulaR1C1 = "=VLOOKUP(LEFT(RC[-2],4),C[-2]:C[-1],2,FALSE)" Range("C2").Select Selection.AutoFill Destination:=Range(Cells(3, 2), Cells(lRow, 3)), Type:=xlFillDefault 変数を使って最終行を指定しても上手くいきませんでした。 (C2:C150)や(C2:C160)といったように「C2」のセルを「C2のセル」から「A列に文字が 入っている行のC列」まで貼り付けたいと思っています。 どのようにVBAを記述したら良いのか教えていただけないでしょうか。

  • Activeセルの最終列の値を代入し、セル最終行までコピーするには

    最終列の値の代入をここで教えていただいてできました。 J = Range("IV2").End(xlToLeft).Column For i = J to 1 Step -1 If InStr(Cells(2, i).Value, "単価") > 0 Then Cells(3, i).Value = Cells(3, J).Value End If Next i この、Cells(3, i).Value = Cells(3, J).Value を、 "単価"列の最終行までコピーするには どのような記述をしたらいいでしょうか? しばらく悩んでいますができません。。。 お力を貸してください。!

  • ある列の計算式が入っているセルの行のみを削除したい

    Excel2007でマクロを作成している超初心者です。 B列のセルには 空白 文字列 計算式が入っています。このうち計算式の入っているセルの行のみを削除したいのですが、どうしたらよろしいでしょうか?  セルには =IF(C17="","",+K17*L17)という式が入っています。 次式は0か空白の場合ですが、これをどのように修正したらできるでしょうか? Sub 行の削除() Dim i As Long For i = 1 To Selection.End(xlDown).Columns Step 1 Select Case Range("B" & i).Value Case 0, "" Columns(i).Delete End Select Next End Sub

  • EXCEL マクロ 列の削除に時間がかかる

    列はY列まで、行はおおよそ400~500行くらいのエクセルの表があります。 マクロで飛び飛びに行の削除を記録したのですが、処理に時間がかかっています。 もっとスムーズに早くする方法はありますか? ご教授おねがいします。 Range( _ "A:D,H:H,I:J,K:K,M:N,P:U,W:W,X:Y"). _ Select Selection.Delete Shift:=xlToLeft

  • マクロで変数を使用して複数列を削除

    エクセル2013です Range("B:C").Delete ' 列「B &#65374; C」を削除 Range(Columns(2), Columns(3)).Delete ' 列「B &#65374; C」を削除 Range("D:D").Delete ' 列「D」を削除 ですが で変数を使って Range(Columns(17), f).Delete ですと動作しません。 ウォッチで見るとfには21がセットされています。 17列目から21列目までの5列が列削除される予定です。 どうもRangeとCellsで片方が変数の場合記述がわかりません。 よろしくお願いします。

  • マクロで不要な行を削除したい

    エクセル97を使っています。  日付 名前 品目 ・・・  1 2 3 ・ ・ といった表で、日付は2003/2/13という表示になっています。 そこで、今日以前(今日は含まない)の日付の行を削除してしまいたいのですが どうすればいいでしょうか? ちなみに、空白行を削除するのに、 Application.ScreenUpdating = False On Error Resume Next With Columns("E:F") .SpecialCells(xlCellTypeConstants).EntireRow.Hidden >=TODAY() .SpecialCells(xlCellTypeFormulas).EntireRow.Hidden >=TODAY() .SpecialCells(xlCellTypeComments).EntireRow.Hidden >=TODAY() .SpecialCells(xlCellTypeVisible).EntireRow.Delete .EntireRow.Hidden = False End With このような記述を使っています。 「今日」というとTODAY()関数ですよね。 でも、関数ってマクロに組み込めるのでしょうか? しかも「今日以前」という記述はどうすればいいのか? など考えると、わけがわからなくなりました。 今日以前の行を削除するマクロを教えてください。 ちなみに、日付の行では、曜日を追記する関数を使っております。 条件書式も3パターン使い切っております。 よって、マクロで行いたいです。 宜しくお願いします。

  • vba エクセル

    2行目から、最終行までEmptyにしたいのにならないです。 1行目はフィールド行なのに、そのままにしたいのですが 2行目から最終行は空白にしたいです。 なので Sub TEST() With Sheets("log") lastRow = .Cells(.Rows.Count, "b").End(xlUp).Row LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column .Range(.Cells(2, LastCol), .Cells(lastRow, LastCol)) = Empty End With End Sub としたのですが、何も起こりません。 lastRowは100、LastColは5なのですが、 このマクロを実行しても何も起こらないです。 なぜでしょうか?

  • マクロLOOP文を別方法で高速化

    シート2のボタンをクリックすると Sub 編集が起動します。 Sub 編集にはCallで2種類のプロシージャーを 呼び出します。 シート1には約20,000行のデータがあります。 処理に約2分かかっています。 もう少し高速にする方法は 有りますでしょうか? プロシージャーは分けておきたいです。 シートに式は入れたくありません。 Sub 編集にはCall文でさらに別のプロシージャーを5個呼び出しますが F8キーで確認すると、それらは秒速で処理されてました。 一番時間がかかっているのがこの部分なので この部分を対策したいです。 よろしくお願いします。 Sub 編集()  Call 検索キー  Call 日付02   Sheets("シート1").Select   Range("R1") = "キー"   Range("S1") = "日付"   Columns("B:B").Select   Selection.Delete Shift:=xlToLeft   Columns("F:F").Select   Selection.Delete Shift:=xlToLeft   Columns("H:O").Select   Selection.Delete Shift:=xlToLeft   Range("A1").Select   MsgBox "編集終了"   Sheets("シート2").Select End Sub   Sub 検索キー()    '2010年11月17日    'R列にC,D,E列を連結させた値を転記     Sheets("シート1").Select     行 = 2     Do     If Cells(行, 1).Value = "" Then Exit Do     Cells(行, 18).Value = Cells(行, 3) & Cells(行, 4) & Cells(行, 5)     行 = 行 + 1     Loop    End Sub    Sub 日付02()     '2010年11月17日     'A列の値、半角数字8桁を下4桁で     '2桁目に/を入れてS列に転記(セルの値もセル表示も)     '例:A列20101117 S列 11/17     'セルの値が2010/11/17でセルの表示が11/27は不可      Sheets("シート1").Select      For 行 = 2 To Cells(Rows.Count, "A").End(xlUp).Row      With Cells(行, 19)      .NumberFormat = "@"      .Value = Format(Cells(行, 1), "!@@/@@")      End With      Next    End Sub

  • 色のないセルの行削除

    任意の色で塗りつぶされたセルがあって、塗りつぶされたセルが存在する行を削除するマクロ。 Sub 行削除() Dim r As Integer Dim c As Integer For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1   For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1     If Cells(r, c).Interior.ColorIndex <> xlNone Then        Rows(r).Delete     End If   Next Next End Sub この逆のことがしたいのですが、わかりません。 ちなみにこのプログラムはそのままC&Pです。 内容もあまり理解できていません。(^_^;) 添付画像の逆に色のついた行だけ残したいです。 よろしくお願いします