- ベストアンサー
エクセルの行を高速に削除する方法
ki-aaaの回答
試してみて Sub 集計() Dim i As Long, r As Long, j As Long Dim v, vv With ThisWorkbook.Sheets("Sheet1") r = .Cells(65536, 1).End(xlUp).Row Application.ScreenUpdating = False v = .Range("A1").Resize(r, 3).Value '一行多く取得 ReDim vv(1 To UBound(v), 1 To 3) For i = 2 To r If v(i - 1, 1) = v(i, 1) And _ v(i - 1, 2) = "A" And v(i, 2) = "B" Then vv(j, 3) = vv(j, 3) + v(i, 3) Else j = j + 1 vv(j, 1) = v(i, 1) vv(j, 2) = v(i, 2) vv(j, 3) = v(i, 3) End If Next i .Range("A2").Resize(r - 1, 3).ClearContents .Range("A2").Resize(j, 3).Value = vv Application.ScreenUpdating = True End With 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 VB 任意のセルから、最終行までの数式のコピー
任意のセルに、計算式を入力しております。 A B C 1 個数 金額 基準単価 2 5 15000 3000 3 123 25780 4 ・ ・ 600 C2には、B2/A2という計算式が入っております。 この計算式を、C600（浮動）までコピーしたいのですが、 どうしてもうまくいきません。。 Sub 基準単価() Dim i As Integer Application.ScreenUpdating = False '1行目で検索 For i = Range("IV1").End(xlToLeft).Column To 1 Step -1 If InStr(Cells(1, i).Value, "基準単価") > 0 Then Cells(2, i).FormulaR1C1 = B2/A2 Cells(2, i)Selection.AutoFill Destination:= Range("Cells(2, i).End(xlDown)).Type:=xlFillDefault End If Next i Application.ScreenUpdating = False End Sub どうぞよろしくお願いします！！
- ベストアンサー
- オフィス系ソフト
- 条件に合った行を削除するマクロについて
こんにちは 今、現在、とある条件にあった行を削除するマクロ作っているのですが、 インターネットを調べてみると後ろから探索して、1行ずつ消していくのがいいと書いてありました。 まぁ、その理屈はわかるんですが、それなら 「Unionでセルの範囲を結合してから、最後に一度に消してしまった方が速いのでは」 (消す作業が1度だけで済むから) と思い試してみたんですが、実際試したところ・・・ ものすごく遅かったです。 (ちなみに、1万件のデータで削除した行数は6000ほどでした） 何故Union結合だと遅いのでしょうか？ 速いマクロを作成するには、やはり後ろから探索して、1行ずつ消していくしかないのでしょうか？ 以下は試したマクロです。 (test が unionで試したマクロ、test2が後ろから1行ずつ削除したマクロ) Option Explicit Public Sub test() Dim r As Range Dim r1 As Range 'Cells.Replace "-", " " For Each r In Range("A2", Range("A65536").End(xlUp)) If r = r.Offset(1, 0) And r.Offset(0, 1) < r.Offset(1, 1) Then If r1 Is Nothing Then Set r1 = r Else Set r1 = Union(r1, r) End If End If Next r1.EntireRow.Delete ' r1.Select End Sub Public Sub test2() Dim r As Range Dim r1 As Range Dim i As Integer 'Cells.Replace "-", " " Application.ScreenUpdating = False For i = Range("A65536").End(xlUp).Row To 1 Step -1 If Cells(i, 1) = Cells(i + 1, 1) And Cells(i, 2) < Cells(i + 1, 2) Then Cells(i, 1).EntireRow.Delete End If Next Application.ScreenUpdating = True End Sub
- ベストアンサー
- Visual Basic
- VBAで削除を早くしたいのですが…
Excel2007のVBAです。キー記録を眺めながら四苦八苦しております。 数千行あるデータで、A列が"d"以外の行を削除したいのですが PCスペックが低いせいか、時間がかかってしまいます。 簡単に効率化することは可能でしょうか？ よろしくお願いします。 ※1行目はタイトル列、全体行数は可変です。 Sub A05_A列がｄ以外は削除する() Application.ScreenUpdating = False Dim sh2 As Worksheet Set sh2 = Worksheets("削list") For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1 If sh2.Cells(i, "A").Value <> "d" Then Rows(i).Delete End If Next Application.ScreenUpdating = True End Sub
- ベストアンサー
- Excel（エクセル）
- VBAで空白行を削除する
VBAでリストの空白行を削除するための適当なコードを探しているのですがどんぴしゃのものが中々見つかりません。ご教授下さい。 ブックBのシートBのリストにはA2～AN●まで値が入っています。 別のブックAからVBAで値を取り出し貼り付けています。 いくつかの方法を試しました。 (1)ブックを開いたときに空白行を削除 Sub Auto_Open() '空白行を削除 Dim lRow As Long Dim i As Long lRow = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False For i = lRow To 2 Step -1 If Cells(i, 1).Value = "" Then Range(i & ":" & i).Delete End If Next i Application.ScreenUpdating = True End Sub 5分以上砂時計のままで結局終わりません。 強制終了させ再度ブックを開くと空白行は削除されているのですが、こんな動作では使うことができません。 (2)ブックAの値を貼り付けた後、空白行を削除し上書き保存する Sub エクスポート() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Range(Cells(5, 7), Cells(79, 46)).Select Selection.Copy 'コピー Workbooks.Open Filename:="\\パス\ブックB.xlsm" '貼り付け先ファイルオープン Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '貼り付け Dim lRow As Long Dim i As Long lRow = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False For i = lRow To 2 Step -1 If Cells(i, 1).Value = "" Then Range(i & ":" & i).Delete End If Next i Application.ScreenUpdating = True '空白行を削除 ActiveWorkbook.Save '上書き保存 Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub (3)空白行を削除の部分は以下のコードも試しました Worksheets("SheetB").Range("A1").Select Set currentCell = Worksheets("sheetB").Range("A1") Do While Not IsEmpty(currentCell) Set nextCell = currentCell.Offset(1, 0) If Not IsEmpty(currentCell) Then 'カレントセルが空白でなく、 If IsEmpty(nextCell) Then '次のセルが空白のとき nextCell.EntireRow.Delete End If End If Set currentCell = currentCell.Offset(1, 0) Loop '空白行削除 宜しくお願い致します。
- 締切済み
- Excel（エクセル）
- VBAで教えてください。
以前ここで教えていただいたＶＢＡで http://jisaku.155cm.com/src/1371930716_9b9006528605642980beed48a8998013b0731e4b.jpg のようにＡ列のテスト４をクリックしたときにＣ列のテスト４が一発で解るようにしたいです。 もちろん、テスト１１をクリックしたときは、テスト４塗りつぶしは解除され、 テスト１１が塗りつぶされるようにしたいです。 写真は塗りつぶししていますが、解るようにしたいだけなので、塗りつぶしにはこだわっていません。 あと、Ｅ、Ｆ、Ｇ列は解りやすく並べているだけで、実際はＡ、Ｂ、Ｃ列だけです。 それと、Ｃ列は関数を使って表示してあります。 という質問で Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'この行から Dim i As Long Range("C:C").Interior.ColorIndex = xlNone If Application.Intersect(Target, Range("A:A")) Is Nothing Or Target.Count <> 1 Then Exit Sub On Error Resume Next Application.ScreenUpdating = False ActiveSheet.Cells.interio.ColorIndex = xlNone For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, "C") = Target Then Cells(i, "C").Interior.ColorIndex = 3 End If Next i Application.ScreenUpdating = True End Sub 'この行まで をシートのコードに張り付ければいいですよ。と教えてくれたものがあるのですが、 Ａ列でクリックした文字をＣ列からすべて見つけて反転してくれないようです。何個か反転してくれない ものが出てきてしまいました。 Ｃ列が何百行とかなってしまうと、すべての同じ文字を検索してくれないのでしょうか？ ちなみに列がここに掲載しているものと違うので Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'この行から Dim i As Long Range("R:R").Interior.ColorIndex = xlNone If Application.Intersect(Target, Range("B:B")) Is Nothing Or Target.Count <> 1 Then Exit Sub On Error Resume Next Application.ScreenUpdating = False ActiveSheet.Cells.interio.ColorIndex = xlNone For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, "R") = Target Then Cells(i, "R").Interior.ColorIndex = 3 End If Next i Application.ScreenUpdating = True End Sub 'この行まで のＣをＲにＡをＢに変更して使ってます。 これがいけないのかな？ よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルマクロ行削除
エクセル2013です。 以下の行削除マクロを作りました。 取得した 最終行が２０行目として 最終列がＺ列として セル Z20 の値が １以上なら問題なく動作するのですが セル Z20 の値が 0 だとループして終了しません。 どこを修正しても、思うように動作しません。 どこを修正すれば、いいのでしょうか？ よろしくお願いします。 Sub 行削除() Dim 最終行 Dim 最終列 Dim 対象行 最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得 最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得 Application.ScreenUpdating = False '画面切替停止 For 対象行 = 10 To 最終行 If Cells(対象行, 最終列) = 0 Then Rows(対象行).Delete 最終行 = 最終行 - 1 '削除により最終行が１行減ったので最終行の値を1行減らす 対象行 = 対象行 - 1 '削除により対象行が1行繰り上がったので対象行の値を1行減らす Else End If Next 対象行 Application.ScreenUpdating = True '画面切替停止解除 End Sub
- ベストアンサー
- Excel（エクセル）
- 二つの条件を満たす行を削除の方法教えて下さい（＞＜）
エクセルは基本的な事しか分からないのですが、 どうしても仕事で必要で、土日に持ち帰ってきたのですが うまくできません。どなたか教えて下さい。 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 で消せたのですが、二つだとうまくいきません。 どなたか教えて下さい。よろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- 条件にて行削除をするをマクロで高速化したい
シート（最初）の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～E列とかA～H列とか ・シート残はA～E列、シート最初はA～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 '検索に使用したＦ列を削除 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
- ベストアンサー
- オフィス系ソフト
- ExcelにおけるVBAで、データの振り分けをしたい
Sub a() Dim i As Long Dim s As Long Dim b As Worksheet Dim c As Worksheet Dim maxi As Long Dim maxs As Long Application.ScreenUpdating = False With ThisWorkbook Set b = .Worksheets("bbb") Set c = .Worksheets("ccc") End With maxi = b.Range("A1").CurrentRegion.Rows.Count maxs = c.Range("A1").CurrentRegion.Rows.Count For i = maxi To 2 Step -1 For s = maxs To 2 Step -1 If c.Cells(s, 1) = b.Cells(i, 1) And c.Cells(s, 2) = b.Cells(i, 2) Then c.Cells(s, 14) = b.Cells(i, 3) End If Next s Next i Application.ScreenUpdating = True End Sub ワークシートcとワークシートbの1列目と2列目が一致したときにだけ、cの14列目にbの3列目のデータを代入したく思い、以上のようなコードを書きましたが、重くて終わる様子がありません。 ・そもそもあっているのか、あっていないならどこを修正すればよいか ・早く終わるようにするにはどうしたらいいか アドバイスをよろしくお願いします。
- 締切済み
- Visual Basic
お礼
遅い時間にありがとうございました。 Sub 集計2()と同データで試してみましたところ大変なスピードで成功しました。 何と1秒ちょっとです！！ 配列にての方法を今1行ずつ勉強しています。 タイトル行を含め一度配列ｖに取り込んで、2行目以降で条件に一致しないデータを別の配列ｖｖにいれて、次行データが条件に一致した場合だけ3列目のデータに加算しているのですね？