- ベストアンサー
マクロを使用してシートの行削除を高速化する方法
end-uの回答
- end-u
- ベストアンサー率79% (496/625)
とりあえず、数式版リベンジ :D MATCH関数の照合の型0じゃなく、照合先を昇順ソートして照合の型を1にします。 例えば =IV2=INDEX(Sheet2!$IV$2:$IV$30000,MATCH(IV2,Sheet2!$IV$2:$IV$30000,1)) こんな式。 Sub try_2() Dim r1 As Range '照合元(残) Dim r2 As Range '照合先(最初) Dim r As Range '削除起点 Dim s As String '数式用 'データ範囲のIV列を取得 With Sheets("sheet1").Range("A1").CurrentRegion.EntireRow Set r1 = Intersect(.Cells, .Offset(1), .Columns("IV")) End With With Sheets("sheet2").Range("A1").CurrentRegion.EntireRow Set r2 = Intersect(.Cells, .Offset(1), .Columns("IV")) End With r1.Formula = "=A2&B2&C2" r1.Value = r1.Value r2.Formula = "=A2&B2&C2" r2.Value = r2.Value '数式用のアドレス取得 s = r2.Address(external:=True) '作業列をIU列に変更 Set r2 = r2.Offset(, -1) '元データの並びを記録 r2.Formula = "=row()" r2.Value = r2.Value 'IV列昇順にソート(数式の為に必要) r2.EntireRow.Sort Key1:=r2.Item(1).Offset(, 1), _ Order1:=xlAscending, _ Header:=xlNo, _ OrderCustom:=1, _ Orientation:=xlTopToBottom '作業列をIU列に変更 Set r1 = r1.Offset(, -1) '数式セット r1.Formula = "=IV2=INDEX(" & s & ",MATCH(IV2," & s & ",1))" r1.Value = r1.Value '数式結果置換 r1.Replace "#N/A", "FALSE", xlWhole 'データ範囲のみソート r1.EntireRow.Sort Key1:=r1.Item(1), _ Order1:=xlAscending, _ Header:=xlNo, _ OrderCustom:=1, _ Orientation:=xlTopToBottom '重複データの先頭を検索 Set r = r1.Find("TRUE", , xlValues, xlWhole) If Not r Is Nothing Then '重複データあれば行全体削除 Range(r, r1(r1.Count)).EntireRow.Delete End If '元データの並びにソートし直し r2.EntireRow.Sort Key1:=r2.Item(1), _ Order1:=xlAscending, _ Header:=xlNo, _ OrderCustom:=1, _ Orientation:=xlTopToBottom '作業列削除 r1.EntireRow.Columns("IU:IV").Delete r2.EntireRow.Columns("IU:IV").Delete Set r = Nothing Set r1 = Nothing Set r2 = Nothing End Sub 30,000×30,000で10secかかりませんので一応、許容範囲かな、と。 #提示コードの検証は慎重に。
関連するQ&A
- 重複行を完全削除するエクセルのマクロ
Sub sakujyo() Dim i, ii As Long For i = 1 To Range("a65336").End(xlUp).Row For ii = Range("a65336").End(xlUp).Row To i + 1 Step -1 If Cells(i, 2).Value = Cells(ii, 2).Value _ And Cells(i, 4).Value = Cells(ii, 4).Value _ And Cells(i, 5).Value = Cells(ii, 5).Value Then Dim iii As Byte iii = 1 Rows(ii).Delete Shift:=xlUp End If Next ii If iii = 1 Then Rows(i).Delete Shift:=xlUp iii = 0 Next i End Sub データーが下の表のように入っております。 A B C E F 1 1/26 a1234 fdsa 5000 C1 2 1/27 a4567 sdfa 4000 T2 3 1/28 a1234 dfsa 5000 C1 4 1/30 b4567 asdf 6600 A2 5 2/10 b4567 fsda 6600 A2 6 2/10 a1234 afds 5000 C1 B列、E列、F列が完全一致(重複1行目と3行目と6行目・4行目と5行目)で削除し結果的に2行目だけ残る方法がしたいのですが、このマクロですと少ないデータですとうまく動くのですが、『大量のデータを一気に削除出来ない』、『同じ重複が3つ以上のデータが多数ある場合データが削除されずに残ってしまう』エラーが出てしまいます。どうかお教えください。
- ベストアンサー
- オフィス系ソフト
- EXCEL 最終行に入力するマクロ
マクロ初心者です。 シート”受注書”からシート”受注履歴”に 履歴情報を書き込むマクロを作成しています。 初心者丸出しで恥ずかしいのですが、 下記のように組んでいます。 Sub 受注情報書き込み() Dim ws01 As Worksheet Dim ws02 As Worksheet Set ws01 = Worksheets("受注書") Set ws02 = Worksheets("受注履歴") ws02.Activate ' 受注No入力 ws01.Range("C2").Copy ws02.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select Selection.PasteSpecial Paste:=xlPasteValues ' 受注日入力 ws01.Range("M2").Copy ws02.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Select Selection.PasteSpecial Paste:=xlPasteValues ' 出荷日入力 Sheets("粗利報告書").Range("D3").Copy ws02.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Select Selection.PasteSpecial Paste:=xlPasteValues ・ ・ ・ この場合、受注書シートが空白の場合、 受注履歴シートも空白になると思うのですが、 次回、履歴を書き込む時に空白を詰めて(最終行に) 入力してしまう事を避けたいです。 空白は残しつつ、一受注を同じ列に入力する為には、 どうしたら良いでしょうか?
- ベストアンサー
- オフィス系ソフト
- VBA 高速化
以下のコードを改良して早く処理できるようにしたいです。素因数分解をして、素因数の数を数えるプログラムです。 Sub 素因数を数える() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim I As Long, j As Long, cnt As Long, wS As Worksheet, k As Long, Set wS = Worksheets("Sheet2") k = Worksheets("Sheet1").Range("A100010").End(xlUp).Row - 1 For dd = 3 To k Call aaa(Range("A" & dd)) Next dd Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Private Sub aaa(ByVal Target As Range) Set wS = Worksheets("Sheet2") If Intersect(Target, Range("A:A")) Is Nothing Or Target.Count > 1 Then Exit Sub With Target If Not IsNumeric(.Value) Then Exit Sub If .Value Mod 1 = 0 Then Range("D1") = .Value For I = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row Do While Cells(Rows.Count, "D").End(xlUp) Mod wS.Cells(I, 1) = 0 cnt = cnt + 1 Cells(Rows.Count, "D").End(xlUp).Offset(1) = Cells(Rows.Count, "D").End(xlUp) / wS.Cells(I, 1) Loop If Cells(Rows.Count, "D").End(xlUp) = 1 Then Exit For Next I End If .Offset(, 1) = cnt End With Range("D:D").Clear End Sub 以前教えていただいたコードを使って書きました。 どういう状況で使っているかといいますと、シート1のA列に自然数を2から順番に並べ、シート2のA列に素数を並べておき、プログラムを実行すると、B列に素数の数が表示されるという具合です。 大変役に立っていたのですが、10萬ほどのデータを扱おうとすると、自分のコンピュータでは時間がかかりすぎます。そこでコードを改良して高速化をしたいのです。 いま考えられる改良点は、 1、D列を使って行っている処理をメモリで行うようにして、セルへのアクセスを省けないか 2、aaaの5行目の、"wS.Cells(Rows.Count, "A").End(xlUp).Row"この処理を簡単な変数の処理で代用できないか ということです。他にも高速化できる方法があれば教えてください。 よろしくお願いします。
- 締切済み
- Excel(エクセル)
- エクセル 同じ内容行削除マクロ 2
シート1、シート2(基準)のB列を比較して同じ内容行を削除したいのですが、「栃木県3」と「#栃木県3」を同じのもと考えて削除されてしまいます。 Sub 削除() Dim wh1 As Worksheet Dim wh2 As Worksheet Dim f As Range Dim wR As Integer Dim mR As Long Dim wStr As String ' Set wh1 = Worksheets("Sheet1") Set wh2 = Worksheets("Sheet2") wR = 0 With wh1 mR = .Cells(Rows.Count, "A").End(xlUp).Row For wR = mR To 1 Step -1 wStr = .Cells(wR, "B") Set f = wh2.Range("B1:B" & wh2.Cells(Rows.Count, "B").End(xlUp).Row).Find(wStr) If Not f Is Nothing Then .Rows(wR).Delete End If Next End With End Sub 解決策教えて下さい。
- ベストアンサー
- オフィス系ソフト
- マクロで全てのシートで条件を満たすシートに行を挿入するにはどうしたらいいですか
マクロ初心者です。自分でも作ってみたのですが、なかなか思うようにいかず困っています。 book内のシート3つ目から最後のシートで、条件に一致するシートの特定位置に行を挿入するということがしたいのですが。 条件とは、1列目の最後の行に「合計」と記入されていれば、行を4行挿入し、上の書式をコピーするというものです。 下記に記しているマクロは、シートを指定した場合には動くのですが、これにシートをnとして、FOR...Nextを付け加えてシートを順番に参照させようとしても、うまくいきません。 Sub 行挿入sample3() With Sheets("10007") For i = 7 To .Cells(Rows.Count, 1).End(xlUp).Row If .Cells(i + 1, 1) = "" Then Exit For ElseIf .Cells(i + 1, 1) = "合計" Then Range(Cells(i + 1, 1), Cells(i + 4, 1)).Select Selection.EntireRow.Insert Range(Cells(i, 1), Cells(i, 3)).Select Selection.Copy Range(Cells(i + 1, 1), Cells(i + 4, 3)).PasteSpecial xlPasteFormats End If Next i End With End Sub 知識をお持ちの方、教えていただけるととても助かります。よろしくお願いします。
- ベストアンサー
- Visual Basic
- 二つの条件を満たす行を削除の方法教えて下さい(><)
エクセルは基本的な事しか分からないのですが、 どうしても仕事で必要で、土日に持ち帰ってきたのですが うまくできません。どなたか教えて下さい。 A B C D 1 3 2 1 4 2 2 2 3 2 2 1 5 4 4 1 3 4 5 2 2 1 2 ちょっと見づらいですが、上記のような表があるとして A列が2 かつ C列が2の行を削除したいです。 条件がひとつだと For R = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1 If Cells(R, "A").Value <> "" ThenIf Cells(R, "A").Value = 2 Then 'Rows(R).Delete xlShiftUp End IfEnd IfNext R で消せたのですが、二つだとうまくいきません。 どなたか教えて下さい。よろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- マクロ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
- ベストアンサー
- オフィス系ソフト
- 行削除のマクロ
B列~F列にデータが入っていてB列の最終行の下セルを選択しクリップボードのデータを貼り付けた後、貼り付けたデータの最初の3行を削除するマクロを作っています。 Sub Macro1() ''Worksheets("Sheet1").Activate ' addrw = Range("b65536").End(xlUp).Offset(1).Row Cells(addrw, 2).PasteSpecial end sub これでB列の最終行の下にデータを貼り付けることまで出来たのですが貼り付けた最初の3行の削除の仕方がわかりません。 いい方法があれば教えていただけないでしょうか。 例えばB列の10行目まで既に入力されていた場合、11行目からクリップボードのデータを貼り付け(ここまでは上のプログラムで出来ました。)、11行目から13行目を削除したいのですがどうしたらいいでしょうか?
- ベストアンサー
- オフィス系ソフト
- エクセル 空の行を削除するマクロについて
エクセルで、特定の列(ここではFの列としてください)が空欄だった場合に、その行ごと削除するマクロを記述したのですが、不完全で困っています。 不完全な部分としては、 ・Fが空であるはずなのに、行が削除されない ・Fが空でもその隣のセル(E)に文字列などが入っていた場合、削除されない 以下が問題のマクロです Dim i As Integer For i = 1 To 300 If Sheets("Sheet1").Cells(i, "F") = "" Then Sheets("Sheet1").Rows(i).Select Selection.Delete Shift:=xlUp End If Next i End Sub 例) A B C D E F 1 あ い う え お か 2 き く け こ さ し 3 す せ そ た ち 4 つ て と な に ぬ 3列目を削除したいです。 問題箇所がお分かりの方、教えていただけませんでしょうか。 宜しくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- 【Excelマクロ】 行全体を選択したい
下記マクロはデータが入っている最終行の次のセル(A列)を選択するマクロです。 但し、A列はデータが入っていないこともあるため、必ずデータが入っているB列をキーにしています。 NT = Cells(Rows.Count, "B").End(xlUp).Row + 1 Range("A" & NT).Select B125までデータが入っていた場合A126にカーソルが置かれますが、本当は126行全体を選択したいのです。 「Range("A" & NT).Select」部分をどのようなマクロに変更したらよろしいでしょうか?
- ベストアンサー
- Excel(エクセル)
お礼
わざわざ、ありがとうございます。 残るべきデータの中で10行だけ削除されます。 なぜ10行だけが削除されるのか分かりません。 A列 英数字で10~14桁 B列 数字4桁 C列 数字4桁 と決まっています。 A列はほとんど英数字混在ですが 数字だけの場合も存在します。 A列が数字だけの場合が抽出できないようです。 (私の勝手な推測です。) 例えば A列:93210200270080 B列:1234 C列:5678 このパターンで シート残 9321020027008012345678 9321020027008012347777 シート最初 9321020027008012345678 これだと 9321020027008012345678は削除 9321020027008012347777は残る が正解ですが 双方削除されてしまいます。 このパターンが10行削除されているみたいです。 どうもありがとうございました。