- ベストアンサー
マクロを使用してシートの行削除を高速化する方法
hananoppoの回答
- hananoppo
- ベストアンサー率46% (109/235)
こんな感じでいかがでしょう。 Sub Sample() Dim LastNum As Long Dim Data() As String, aData As String Dim rNum1 As Long, rNum2 As Long Application.ScreenUpdating = False Worksheets("最初").Activate LastNum = Cells(Rows.Count, 1).End(xlUp).Row ReDim Data(2 To LastNum) For rNum1 = 2 To LastNum Data(rNum1) = Cells(rNum1, 1).Value & Cells(rNum1, 2).Value & Cells(rNum1, 3).Value Next rNum1 Worksheets("残").Activate For rNum2 = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 aData = Cells(rNum2, 1).Value & Cells(rNum2, 2).Value & Cells(rNum2, 3).Value For rNum1 = 2 To LastNum If Data(rNum1) = aData Then Rows(rNum2).Delete Data(rNum1) = Data(LastNum) LastNum = LastNum - 1 Exit For End If Next rNum1 Next rNum2 Application.ScreenUpdating = True End Sub
関連する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 データーが下の表のように入っております。 Ａ Ｂ Ｃ Ｅ Ｆ １ 1/26 a1234 fdsa 5000 Ｃ1 ２ 1/27 a4567 sdfa 4000 Ｔ2 ３ 1/28 a1234 dfsa 5000 Ｃ1 ４ 1/30 b4567 asdf 6600 Ａ2 ５ 2/10 b4567 fsda 6600 Ａ2 ６ 2/10 a1234 afds 5000 Ｃ1 Ｂ列、Ｅ列、Ｆ列が完全一致（重複１行目と３行目と６行目・４行目と５行目）で削除し結果的に２行目だけ残る方法がしたいのですが、このマクロですと少ないデータですとうまく動くのですが、『大量のデータを一気に削除出来ない』、『同じ重複が３つ以上のデータが多数ある場合データが削除されずに残ってしまう』エラーが出てしまいます。どうかお教えください。
- ベストアンサー
- オフィス系ソフト
- 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のＡ列に自然数を2から順番に並べ、シート2のＡ列に素数を並べておき、プログラムを実行すると、Ｂ列に素数の数が表示されるという具合です。 大変役に立っていたのですが、10萬ほどのデータを扱おうとすると、自分のコンピュータでは時間がかかりすぎます。そこでコードを改良して高速化をしたいのです。 いま考えられる改良点は、 1、Ｄ列を使って行っている処理をメモリで行うようにして、セルへのアクセスを省けないか 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文を別方法で高速化
シート２のボタンをクリックすると Sub 編集が起動します。 Sub 編集にはＣａｌｌで2種類のプロシージャーを 呼び出します。 シート１には約20,000行のデータがあります。 処理に約2分かかっています。 もう少し高速にする方法は 有りますでしょうか？ プロシージャーは分けておきたいです。 シートに式は入れたくありません。 Sub 編集にはCall文でさらに別のプロシージャーを5個呼び出しますが Ｆ８キーで確認すると、それらは秒速で処理されてました。 一番時間がかかっているのがこの部分なので この部分を対策したいです。 よろしくお願いします。 Sub 編集() Call 検索キー Call 日付02 Sheets("シート１").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("シート２").Select End Sub Sub 検索キー() '2010年11月17日 'R列にC,D,E列を連結させた値を転記 Sheets("シート１").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("シート１").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 つ て と な に ぬ ３列目を削除したいです。 問題箇所がお分かりの方、教えていただけませんでしょうか。 宜しくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- 【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（エクセル）
お礼
私のＶＬＯＯＫＵＰと同じ処理結果でかつ 1秒かかりませんでした。 20,000行でも挑戦してみます。 どうもありがとうございました。
補足
シート最初 10,046行 シート残 11,425行 とデータが増えたら 約20秒と処理時間が長くなりました。 でも素晴らしいです。 どうもありがとうございました。 ただ記述にコメントを入れたいのですが どの分が何をしているのか分からず 入れれないです。すいません。