• 締切済み

重複データーの集計、削除

どなたかご教授下さい。 下記のようにD列に重複する行があればI列に集計し、行削除するマクロを作成しました。 さらに、重複する基準となる列を複数(D列,F列,Ｇ列)に増やしたいのですが、上手く出来ません。 宜しくお願い致します。 Sub test() Dim i, j For i = 19 To Cells(Rows.Count, 2).End(xlUp).row - 1 For j = Cells(Rows.Count, 2).End(xlUp).row To i + 1 Step -1 If Cells(i, 4).value = "" Then Exit Sub If Cells(i, 4).value = Cells(j, 4).value Then Cells(i, 9).value = Cells(i, 9).value + Cells(j, 9).value Rows(j).Delete End If Next Next End Sub

みんなの回答

  • bin-chan
  • ベストアンサー率33% (1403/4213)
回答No.5

If Cells(i, 4).value = Cells(j, 4).value Then を If Cells(i, 4).value = Cells(j, 4).value _　''valueの後ろに半角スペースと半角アンダースコア And Cells(i, 5).value = Cells(j, 5).value _　''valueの後ろに半角スペースと半角アンスコア And Cells(i, 6).value = Cells(j, 6).value Then に変更

  • tom04
  • ベストアンサー率49% (2537/5117)
回答No.4

こんばんは！ 安直な方法になってしまいますが・・・ 作業用の列を2列使っています。 Sub test() Dim i As Long Columns("D:E").Insert Application.ScreenUpdating = False For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row Cells(i, 4) = Cells(i, 6) & Cells(i, 8) & Cells(i, 9) Next i For i = 1 To Cells(Rows.Count, 4).End(xlUp).Row If WorksheetFunction.CountIf(Range(Cells(1, 4), Cells(i, 4)), Cells(i, 4)) = 1 Then Cells(i, 5) = WorksheetFunction.SumIf(Columns(4), Cells(i, 4), Columns(11)) End If Next i For i = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1 If Cells(i, 5) = "" Then Rows(i).Delete Else If Cells(i, 5) <> Cells(i, 11) Then Cells(i, 11) = Cells(i, 5) End If End If Next i Application.ScreenUpdating = True Columns("D:E").Delete End Sub ※　For～Next　で3度LOOPしていますので、他に良い方法があればごめんなさいね。m(_ _)m

  • mu2011
  • ベストアンサー率38% (1910/4994)
回答No.3

>上手く出来ません。 　⇒何が「上手くいかない」のかが不明です。 　　補足説明した方が良いのではないでしょうか。

nonkoooo
質問者

補足

上手く出来ません ↓ 重複する基準となる列を複数にする場合のマクロのコードが上手く出来ません。 If Cells(i, 4).value = Cells(j, 4).value Then このように、一つの列だけを基準とする場合は上記のようなコードで良いのですが、 複数列を基準にしようとした場合コードをどのように組めば良いかわかりません。 例 … D　・ F　　 G 　・ I 1 東京 バラ 　5輪 　　5 2　大阪　 バラ 5輪 　　5 3　福岡　 ユリ　　3輪 　　 5 4　大阪　 ユリ　　3輪 　　4 5　東京　 バラ　 5輪 　　5 ↓ … D　・ F　　 G 　・ I 1 東京 バラ 　5輪 　 10 　　 2　大阪　 バラ 5輪 　　5 3　福岡　 ユリ　　3輪 　　 5 4　大阪　 ユリ　　3輪 　　4 5 (A,B,C,E,H列は省略しています) <説明> D,F,G列3列の値が同じになる行がある場合I列で足し算され、加算された行の値は削除 異なる場合は、そのまま残る。というようにマクロで出来ればと思っています。 今の状態だと、D列が同じ行はF,G列が異なっても全て加算され削除されてしまいます。 宜しくお願いします。

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.2

2重ループの部分は下記を参考に考えては。 Sub test01() MsgBox "全行数=" & Rows.Count For Each cl In Range("d1, f1, h1") MsgBox "現在の処理列" & cl.Column d = Cells(Rows.Count, cl.Column).End(xlUp).Row MsgBox "データ最終行=" & d For i = 1 To d MsgBox Cells(i, cl.Column) '本番はここで処理のコードを書く Next i Next End Sub 常識的に考えて、１０列程度以内なら、Range("d1, f1, h1")　のところに書き込んで 飛び飛び列を処理する場合は上記がすっきり書けるコードの１つだろう。

  • bin-chan
  • ベストアンサー率33% (1403/4213)
回答No.1

Forループの終了値 > Cells(Rows.Count, 2).End(xlUp).row - 1 は、いくつを期待してますか？ 行削除するときは、最下行から先頭行に向けてループさせないと、 「今ドコにいるのかわからない」ことになります。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連する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, 4).Value = Cells(ii, 4).Value _ And Cells(i, 13).Value = Cells(ii, 13).Value Then Delete Shift:=xlUp End If Next ii Next i End Sub マクロに関しては、素人でございます。 こちらのマクロを作ってみたのですがうまくいきません。 ４列目と１３列目の列が重複したときのみ重複した行をすべて削除させたいと思っております。どうぞお教えください。

  • シート内の特定のセルの範囲が変化した時、

    シート内の特定のセルの範囲が変化した時、 まずＡ列の最大値を求めて、その後Ａ列とＤ列のそれぞれの条件にあった行のＡ列に 最大値＋１を表示させるようにしたいのですが動作しません。 なぜ動かないか教えて下さい。 参考までに、そのプログラムを記載します。 宜しくお願いします。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row <= 3 Or Target.Row > 65000 And Target.Column = 4 Then Dim i, j, max As Integer max = 0 For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row If max < Range("A" & i).Value Then max = Range("A" & i).Value End If Next i For j = 3 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(j, 1) = "" And Not Cells(j, 4) = "" Then Cells(j, 1) = max + 1 End If Next j End If End Sub

  • エクセル重複行統合マクロの意味

    Tom04さんの回答で 以下のとても素晴らしいマクロがあり、 使用させていただきたいのですが、 詳細がわかりません。 少々編集して自分の書類に反映させていただきたく、 マクロの内容を教えていただけませんか？ Sub test() 'この行から Dim i, j, k, L As Long Application.ScreenUpdating = False For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column + 1 For k = Cells(Rows.Count, j).End(xlUp).Row To 2 Step -1 If Cells(k, j) <> "" And WorksheetFunction.CountIf _ (Range(Cells(2, 1), Cells(k, 1)), Cells(k, 1)) > 1 Then L = WorksheetFunction.Match(Cells(k, 1), Columns(1), False) Cells(k, j).Cut Destination:=Cells(L, j) End If Next k Next j Next i For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If WorksheetFunction.CountA(Rows(i)) = 1 Then Rows(i).ClearContents End If Next i Application.ScreenUpdating = True End Sub 'この行まで

  • excelマクロの重複セルの削除について

    excelマクロ超初心者です。 Ｅ列に下記のようにデータが入っていたとします。 　　Ｅ列 １　いちご ２　りんご ３　みかん ４　いちご ５　りんご ６　れもん これを重複セルを削除して 　　Ｅ列 １　いちご ２　りんご ３　みかん ４　れもん としたいのですが、どうすればいいでしょうか？ 自分なりに調べて、下記のように記述したのですが、 Sub test() lastRow = wb.Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row 'E列最終行 For i = lastRow To 2 Step -1 If Cells(i, 5).Value = Cells(i - 1, 5).Value Then Cells(i, 5).EntireRow.Delete Shift:=xlUp End If Next i End Sub() Ｅ４列から下のデータしか重複セルが削除されません。 ここでいうlastRow To 2 Step -1はどういう意味なのでしょうか？ すみませんが宜しくお願いします。

  • 重複行を完全削除するエクセルのマクロ

    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 Ｂ列、Ｅ列、Ｆ列が完全一致（重複１行目と３行目と６行目・４行目と５行目）で削除し結果的に２行目だけ残る方法がしたいのですが、このマクロですと少ないデータですとうまく動くのですが、『大量のデータを一気に削除出来ない』、『同じ重複が３つ以上のデータが多数ある場合データが削除されずに残ってしまう』エラーが出てしまいます。どうかお教えください。

  • 上のセルのコピーのマクロについて

    下記コードで、B列（数値）の空白のセルにその上の値をコピーしているんですが、C列（日付）で行ったところ、できませんでした。 Integerが違うと思って変えたんですが、ほかにも関連して変えるところがありますか？？ 宜しくお願いいたします。 Sub 上のセルコピー() Dim i As Integer For i = 1 To Range("B" & Rows.Count).End(xlUp).Row If Cells(i, 2).Value = "" Then Cells(i, 2).Value = Cells(i - 1, 2).Value End If Next i End Sub

  • 日付が同じなら削除

    すみません、誰か教えて頂けませんでしょうか。 A列に日付と時間が記入されているのですが、日付だけを比較して 同じなら削除したいのですが、誰かご教授頂けませんでしょうか。 A列 2013/8/14 8:00 2013/8/14 8:15 2013/8/14 10:00 2013/8/15 8:00 2013/8/16 8:00 2013/8/17 8:00 2013/8/17 20:00 2013/8/18 8:00 2013/8/18 9:00 A列 2013/8/14 8:00 2013/8/15 8:00 2013/8/16 8:00 2013/8/17 8:00 2013/8/18 8:00 Sub 削除 () Dim r As Long Dim y As Long r = Cells(Rows.Count,1).End(xlUp).Row For y = r To 1 Step -1 If Cells(y,1).Value = Cells(y,1).Offset(1,0) Then 'この比較がわかりません。 Cells(y,1).Offset(1,0).Delete(xlUp) End If Next y End Sub すみませんが、宜しくお願いします。

  • 当てはまらない場合は色付けして飛ばす

    先日、完全に一致するものを削除する。http://okwave.jp/qa/q6462240.htmlにて教えていただいたことを応用して、別のVBAを作ることにしましたが、今回は必ずしもID（A列）が二つ存在するわけではないため、上下のIDを比較して違った場合は１列色づけし、比較は飛ばして次に進む、というVBAを入れたいのですが、上下同じIDを1列色づけしたり、ひとつしかないIDが続くと止まったりしてしまいます。 間違いもしくは、違う考え方など教えてください。 With Worksheets("差分") For i = 1 To Range("A" & Rows.Count).End(xlUp).Row For j = 2 To 37 If Cells(i, 1).Value <> Cells(i + 1, 1) Then .Cells(i, 1).Interior.ColorIndex = 36 End If If Cells(i * 2, j).Value <> Cells(i * 2 + 1, j) Then .Cells(i * 2, j).Interior.ColorIndex = 44 .Cells(i * 2 + 1, j).Interior.ColorIndex = 6 .Cells(i * 2, 41).Value = "*" .Cells(i * 2 + 1, 41).Value = "*" Else .Cells(i * 2, 40).Value = "重複" .Cells(i * 2 + 1, 40).Value = "重複" End If Next Next End With

  • 【Excel VBA】データ貼り付けの開始位置について

    Excel2003を使用しています。 先日、こちらでアドバイスをいただきながら、下記のようなマクロを作りました。内容はあるセルの値と同じ名前のシートへデータをコピーするというものです。 Sheet1に貼り付け元のデータが表形式であり、必要なデータのみ該当のシートへコピーします。マクロ実行後は、別の新しいデータをSheet1へコピペして、またマクロを実行するのですが、その際、データの貼り付け開始位置を前回マクロを実行して貼り付けられたデータから2行空けたいのですが、可能でしょうか？ ________________________________________________________________________________________________________________________________ Sub test3() Dim n As Long Dim i As Long Dim j As Long 　Worksheets("Sheet1").Activate 　　For n = 4 To Cells(Rows.Count, 2).End(xlUp).Row 　　　If Cells(n, 3).Value <> "" Then 　　　　With Worksheets(CStr(Cells(n, 3).Value)) 　　　　　　i = .Cells(Rows.Count, 3).End(xlUp).Row + 1 　　　　　　Cells(n, 2).Copy .Cells(i, 2) 　　　　　　Cells(n, 7).Resize(, 2).Copy .Cells(i, 4) 　　　　　　Cells(n, 11).Copy .Cells(i, 3) 　　　　End With 　　　End If 　　　If Cells(n, 13).Value <> "" Then 　　　　With Worksheets(CStr(Cells(n, 13).Value)) 　　　　　　j = .Cells(Rows.Count, 3).End(xlUp).Row + 1 　　　　　　Cells(n, 12).Copy .Cells(j, 2) 　　　　　　Cells(n, 17).Copy .Cells(j, 4) 　　　　　　Cells(n, 18).Copy .Cells(j, 6) 　　　　　　Cells(n, 11).Copy .Cells(j, 3) 　　　　End With 　　　End If 　　Next n End Sub

  • マクロで複数の行をまとめて切り取りする方法

    Ｉの列のセルに「テスト」があったら、その行を切り取ってシート2に貼り付ける といった流れのコードが下記です。 Sub 切り取り() Dim i, LastRow As Long LastRow = Cells(Rows.Count, 9).End(xlUp).Row For i = 1 To LastRow If Cells(i, 9) = “テスト” Then Rows(i).Cut Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next i End Sub ●Ｉの列のセルに「テスト」と「課題」があったら、その行を切り取ってシート2に貼り付ける といったものをしたいのです。 1. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト,課題” Then 結果エラー 2. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト&課題” Then 結果エラー 正常なコードを教えてくださいますか？ 宜しくお願いします。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する