[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『数字の大きい行以外は削除』（aki）
エクセルバージョン：EXCEL2000 OSバージョン ：Windows2000
いつもお世話になっております。
データ量が30,000以上ある中で必要なもの以外を削除して
スマートにしたいのですが、あまりに多すぎて原始的作業での
削除には限界を感じております。。そでこVBA等で削除したいのですが、
条件の設定の仕方等が思いつきません。どなたかヒント/ご教授いただきます
様、宜しくお願い致します。
A B
1 aaaa 1
2 aaaa 2
3 aaaa 3
4 bbbb 2
5 bbbb 4
6 bbbb 6
7 cccc 5
8 cccc 6
9 cccc 7
10 cccc 8
上記のような表の中で、aaaaの中でB列で一番大きな数字3以外の行、
bbbbの中でB列で一番大きな数字6以外の行、ccccの中でB列で一番大きな数字8以外の行、
等を一気に削除したいのですが、どの様にすればいいのでしょうか？
ヒントです。一行目に見出しを付け、データ、統合で、集計の方法で最大値、統合の基準に 上端行、左端列を指定して、実行しますと、最大値の行だけ抽出できます。 (LOOKUP)
LOOKUPさんにヒントいただけるなんて感激です！！ 「統合」と言うものは初めて知りました。最初、統合先と統合元を同じに選択して しまい、悪戦苦闘しましたが、何とかできました。すごーい！！ なのですが、実はBB列まで項目がある表なのですが、統合された表には数字は 入っているのですが、品名等、文字列は空白になってしまいます。 初めて使ったものですから ？？？です。なぜなのでしょうか？(aki)
ご質問の内容で回答差し上げたのですが。。A列とB列だけでは、ないのですね。 統合では、数値以外の項目は、対象とされないように思います。 また、そのように項目が多数の場合には、並び替えをしたのち、マクロで前後の 行データと比較して、行削除するのが、よいように思います。 別の回答者のご回答を待ってください。 数式で処理するものを私が試行しますと、C列を挿入し、うえから連番を付けて、 統合を実行後、 =INDEX(X:X（該当列範囲）,$F2)などで抽出することになります。
A B C D E F AA BB CC AA BB CC aaaa 1 2 aaaa 3 4 =INDEX(X:X（該当列範囲）,$F2) aaaa 2 3 bbbb 6 7 ↓ aaaa 3 4 cccc 8 11 bbbb 2 5 bbbb 4 6 bbbb 6 7 cccc 5 8 cccc 6 9 cccc 7 10 cccc 8 11 (LOOKUP)
このような方法はいかがでしょう。 まず、データ範囲を選択しメニューの「データ＞並び替え」 最優先されるキーを「A列」昇順、２番目に優先されるキーを「B列」降順にしOK。 その後、BC列へ「=IF(A1<>A2,1,0)」と入力し、式を下方コピー。 メニューより「データ＞フィルタ＞オートフィルタ」 BC列で1を選択。 これで最大値のみが可視セルとなりますので、行を範囲選択のあとメニューの 「編集＞ジャンプ＞セル選択＞可視セルにチェック＞OK」 で反転したところをコピー、別のシートまたはブックに貼り付け。
手間はかかりますが。。。(綾波)
こんにちわ。 VBAで、
Sub del_rows() Dim i As Long i = 1
Do While Range("A" & i).Value <> ""
With Range("A" & i)
Select Case .Value
Case "aaaa"
If .Offset(, 1).Value < 3 Then
.EntireRow.Delete
i = i
Else
i = i + 1
End If
Case "bbbb"
If .Offset(, 1).Value < 6 Then
.EntireRow.Delete
i = i
Else
i = i + 1
End If
Case Else
If .Offset(, 1).Value < 8 Then
.EntireRow.Delete
i = i
Else
i = i + 1
End If
End Select
End With
Loop
End Sub
(jindon)
LOOKUPさん、最初の質問時にデータの状態をちゃんと説明するべきでした、 申し訳ありません。ですが、今まで知らなかった「統合」を知ることができて 大変勉強になりました。追加で教えていただいた数式で統合後に文字列も 入りました。他に早くできる方法が見つからない場合は、これでがんばります。 ありがとうございました。
綾波さん、回答ありがとうございました。手間と言っても以外に時間かからず
できそうだったのですが、LOOKUPさんご指摘の通り、私の最初の説明が悪く申し訳
なかったのですが、
A B
1 aaaa 1 2 aaaa 2 3 aaaa 2 4 aaaa 3 5 bbbb 2 6 bbbb 4 7 bbbb 6 8 bbbb 6 9 bbbb 6 10 cccc 5 11 cccc 6 12 cccc 7 13 cccc 8 14 cccc 8
上記の様に、B列にCCCCに対して同数字が入る表になりますので、綾波さんの数式ですと、 [8]が2つある場合でも1つしか可視セルになりません。 それと綾波さんの数式ですと、1が可視セルになると考えてよろしいのでしょうか？ 私の表ですと、aaaaの最大値には[0]が付いてしまいます。数式どの様にすれば最大値も [1]になるのでしょうか？
jindonさん、VBAのコードを教えていただき、ありがとうございました。
最初の質問時に説明しなかった私が悪いのですが、A列に入る、aaaa,bbbbは
書類の追番号でして、種類が何千にも上ります。それを1つづ CASEで振り分ける
コードはとっても長くなってしまいますね。。自分で思いもつかないのに、大変
申し訳ありません。。これを突破口に自分でコードを悪戦苦闘致しますが、
更なるヒントがある方は宜しくお願い致します。
最初の質問の仕方の大事さを痛感いたしました。説明不足も多々ある質問ですが、
何卒宜しくお願い致します。m(__)m (aki)
最大値１行のみということで思いついた案です。 ２行とも抽出となると式は要をなしませんので破棄してください。 ※ 解決できてよかったですね(^^) (綾波)
もし検査値を別シートから参照できるのであれば、 参照シートをTestValue（仮名）として A,B列にそれぞれ検査値を入力して
Sub del_rows()
Dim i As Long, ii As Long, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("TestValue")
Application.ScreenUpdating = False
i = 1
Do While ws2.Range("A" & i).Value <> ""
For ii = 1 To ws1.Range("A65536").End(xlUp).Row
If ws1.Range("A" & ii).Value = ws2.Range("A" & i).Value Then
If ws1.Range("B" & ii).Value <> ws2.Range("B" & i).Value Then
ws1.Range("A" & ii).EntireRow.Delete
ii = ii - 1
End If
End If
Next
i = i + 1
Loop
Set ws1 = Nothing
Set ws2 = Nothing
Application.ScreenUpdating = True
End Sub
でSheet1のA列の値が、TestValueのA列の値と同じで、B列が違う行を削除します。 違っていたら、無視してください。 (jindon)
あまり自信ないけど、こんな感じでどうでしょう？ シートの見出しを右クリック コードを表示させて、真っ白なところに貼り付けて下さい。 外してたら、、、、ごめんなさいねm(__)m では、清水の舞台より、ダイブですぅ。。。。どった。。ドッスン！！！
あっ！必ず、ばっくあっぷをとっておいてくださいね。
(夏目雅子似）
Sub 複数重複行の削除()
Dim i As Long
Application.ScreenUpdating = False
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), _
Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
With Range("A1")
For i = .CurrentRegion.Rows.Count To 1 Step -1
If .Offset(i, 0) = .Offset(i - 1, 0) And .Offset(i, 1) < .Offset(i - 1, 1) Then
.Offset(i, 0).EntireRow.Delete Shift:=xlUp
ElseIf .Offset(i, 0) = .Offset(i - 1, 0) And .Offset(i, 1) > .Offset(i - 1, 1) Then
.Offset(i - 1, 0).EntireRow.Delete Shift:=xlUp
ElseIf .Offset(i, 0) = .Offset(i - 1, 0) And .Offset(i, 1) = .Offset(i - 1, 1) Then
.Offset(i, 0).EntireRow.Delete Shift:=xlUp
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
お久しぶりです。１ヶ月前に質問を投げておいてそのままにしていて 申し訳ありませんでした。他の仕事が忙しくこの件に関しては中断しておりました。 (jindon)さん、(夏目雅子似）さん、ありがとうございました。 御二方のコードを試用したのですが、下記の様になってしまいます。
（私の希望）：A列を基準にしてB列の最大値が全部残るようにしたい
（C列の数値に関係なく）
A B C
1 aaaa 1 1
2 aaaa 2 1 3 aaaa 2 2 4 aaaa 3 3 ←残る ←残る 5 bbbb 2 1 6 bbbb 4 1 7 bbbb 6 2 ←残る 8 bbbb 6 3 ←残る 9 bbbb 6 4 ←残る ←残る 10 cccc 5 1 11 cccc 6 1 12 cccc 7 1 13 cccc 8 1 ←残る 14 cccc 8 2 ←残る ←残る
私なりに、（夏目雅子似）さんが、（ちびねこ）さんに回答した
コードを少し変えて動かしたのですが、どうしてもB列に連動して
C列の最大値の一行のみが残る結果になります。
Sub 最大の行以外を削除()
Dim i As Long
Dim myTimer As Single
myTimer = Timer
Application.ScreenUpdating = False
Range("A1").CurrentRegion.Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlPinYin
With Range("A1")
For i = .CurrentRegion.Rows.Count To 1 Step -1
'A列の上下が同じでかつB列の上が小さい場合
If .Offset(i, 0) = .Offset(i - 1, 0) And .Offset(i, 2) >
.Offset(i - 1, 2) Then
'A列の上下が異なるまで下記の処理を繰り返す
Do While .Offset(i, 0) <> .Offset(i - 1, 0)
'上の行を削除
.Offset(i - 1, 0).EntireRow.Delete Shift:=xlUp
Loop
End If
Next i
End With
Application.ScreenUpdating = True
myTimer = Timer - myTimer
MsgBox Format(myTimer, "#,##0.00") & "秒 削除完了"
あと時間がすごくかかってしまって。。。データ量が多いので、マクロを
走らせると削除が完了するまで約２４分かかりました。
途中で質問止めておいてなんですが、また皆様宜しくお願い致します。
(aki)←私もたまにしか登校（質問）しないのですが、
違うAKIさんがいらっしゃるようですので、
ニックネーム変えようと思います。
これからは(オーパフメ）でお願いします。
オーパフメさん、こんにちは^^ [[20040702174544]]『各レコードの最新版だけをそれぞれ抽出したい』（ちびねこ） こちらですね。 スピードの事は、良くわかりませんが、↓こんな感じで どうでしょう？ （夏目雅子似） Sub 複数重複行の削除()
Dim i As Long
Application.ScreenUpdating = False
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlPinYin
With Range("A1")
For i = .CurrentRegion.Rows.Count To 1 Step -1
'A列の上下が同じで 且つ B列の上の行が下の行より大きかったら
If .Offset(i, 0) = .Offset(i - 1, 0) And .Offset(i, 1) < .Offset(i - 1, 1) Then
'下の行を削除
.Offset(i, 0).EntireRow.Delete Shift:=xlUp
'A列の上下が同じで 且つ B列の下の行が上の行より大きかったら
ElseIf .Offset(i, 0) = .Offset(i - 1, 0) And .Offset(i, 1) > .Offset(i - 1, 1) Then
'上の行を削除
.Offset(i - 1, 0).EntireRow.Delete Shift:=xlUp
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
（オーパフメ）
おはようございます。 >それは解決難しいでしょうか。。 いろんな方法があると思いますが、一応フィルターを使う方法を考えてみました。 （早いかどうかはわかりません。） データに対してA列の種類が少ない場合は、少し早いかもしれませんが >書類の追番号でして、種類が何千にも上ります と、なると、、動くかどうかわかりません。汗^^;
フィルターを使うので、今回は見出しが必要です。 (フィルターを使うにしても、もう少しましな方法があると思うのですがぁ、、お許しを(>_<)） A B C 1 項目1 項目2 項目3 2 aaaa 1 1 3 aaaa 2 1 4 aaaa 2 2 こんな感じです。それから、コードにも書いていますが、作業列を使うので、 データのABC3列以外は入力しないでください。 ほとんど、マクロの記録ばっかりですが、汗^^; シートの見出しを右くりっく コードを表示させて↓を貼り付けたら、D1をたたいてみてください。 と、いうわけで今回は私をたたかないでください。(^^)v で、どうしょう？ あっ、ばっくあっぷは必ずとっておいてくださいね。 （夏目雅子似）
'DIをダブルクリックすると抽出マクロを開始します。 'データはABCの3列のみで各フィールドに見出しが必要です。（項目1 項目2 項目3など） '作業列としてP列まで使用しますのでシートにはABCの3列以外には何も入力しないでください。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim MyRow As Long Dim MyRng As Range Dim FirstAdd As String Dim MyData As Variant Dim myTimer As Single
'ターゲットがD1じゃなかったら無効
If Target.Address <> "$D$1" Then Exit Sub
'ターゲットの一つ下を選択
Target.Offset(1).Select
'画面の更新を禁止
Application.ScreenUpdating = False
'データの並び替え
Range("A1").CurrentRegion.Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlDescending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlPinYin
'最終行の取得
MyRow = Range("A65536").End(xlUp).Row
'D列に数式をセットして重複項目をカウント
With Range("D2")
.FormulaR1C1 = "=COUNTIF(R2C1:RC[-3],RC[-3])"
.AutoFill Destination:=Range("D2" & ":" & "D" & MyRow)
End With
'Findで「1」を検索
Set MyRng = Range("D2" & ":" & "D" & MyRow). _
Find(What:="1", LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=True)
'「1」が無かったら終了
If MyRng Is Nothing Then Exit Sub
'最初のアドレスを取得
FirstAdd = MyRng.Address
'見出しをコピー
With Range("A1:C1")
.Copy Range("F1")
.Copy Range("N1")
End With
'タイマー計測開始
myTimer = Timer
'ループのはじまり
Do
'D列を順に検索
Set MyRng = Range("D2" & ":" & "D" & MyRow).FindNext(MyRng)
'もしも、「1」がなかったらループを抜ける
If MyRng Is Nothing Then Exit Do
'最初にヒットしたデータを取得
MyData = Cells(MyRng.Row, 1).Resize(, 2).Value
'検索条件F2:G2にMyDataを代入
Range("F2:G2").Value = MyData
'フィルターでJ列に抽出
Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("F1:G2"), CopyToRange:=Range("J1"), Unique:=False
'見出しを残してデータをN列にコピー
With Range("J1").CurrentRegion
.Offset(1).Resize(.Rows.Count - 1, .Columns.Count).Copy Range("N65536").End(xlUp).Offset(1)
'抽出結果を消去
.ClearContents
End With
'一周したらループを終了
Loop Until MyRng.Address = FirstAdd
'作業列を消去
Columns("A:M").Delete Shift:=xlToLeft
'タイム測定終了
myTimer = Timer - myTimer
MsgBox Format(myTimer, "#,##0.00") & "秒 抽出完了" & Chr(13) & Chr(13) & _
"少し早くなったかな？(^^)V", vbInformation, "エクセルの学校 VBA"
'変数のクリア
Set MyRng = Nothing
'画面の更新解除
Application.ScreenUpdating = True
End Sub
(夏目雅子似）さん、ご教授ありがとうございました。 お礼が遅くなり申し訳ありませんでした。m(_ _)m 時間短縮の為に考えいただいたコードですと、A,B,C列以外は 作業列になってしまうとの事。。。データはZ列まであり、少々 時間はかかりますが、それ以前に教えていただいたコードを 参考にさせていただき、思うようにデータが整理できました。 本当に面倒な質問に忍耐強くお付き合いいただき、ありがとうございました。 これからも宜しくお願い致します。
（オーパフメ）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.