[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『一致するデータを範囲を指定して削除したいです』(佐竹ゆうこ)
エクセル初心者です。やさしくお願いします。
B10からB29までに、数値(1から999)を入れると、
B36からB300までで一致する数値を探し(B列で検索)、
一致したら、その行のBからМ列までを消して、上につめるマクロをおしえてください。
B36から下は在庫帳簿になっており、
B10からB29が使用したものの帳票です。
使うと、B36から下の一致したデータのB列からМ列までが消える形です。
ほかにも同じシートにいろいろデータが詰まっていて、
該当する範囲のみ削除するのがうまくいきません。
よろしくお願いいたします。
例 Bに45という数値が入ると、B36からМ36のデータが消えて、下のデータが上に上がる。
なたね油の行が新たにB36列目にくる。
_________ __ __B____C__________D_______E
___10行目__45___酒かす___4種____岩手___農協____1キロ_____200円
___29行目
____________B______C__________D________E___________F_____G_____H____________I_____J________K_____L____M
__36行目__45___酒かす___1キロ___200円___ 農協__4___10月4日_____________________________境山
__37行目__71___なたね油_10L_____450円___角館___5___10月27日__20_石丸____10%______相沢
__38行目__103__牛糞_____20キロ__820円___埼玉___8___11月12日___________一般_____C_____風見
300まであります。エクセル2010使用です。
< 使用 Excel:Excel2004(Mac)、使用 OS:Windows7 >
(マナ) 2018/03/10(土) 17:11
まずは、手作業で試してみるとよいです。
使ったことがなければ、ネットで検索してみてください。
(マナ) 2018/03/10(土) 17:23
はい。承知しています。
>やさしくお願いします。
ということなので、
>まずは、手作業で試してみるとよいです。
(マナ) 2018/03/10(土) 17:43
マクロの使い方は出来ますか?
Sub 在庫数字削除()
Dim i As Long Dim cnt As Long Dim rrr As Range Dim crR As Range Dim rlist As Range
Set crR = Range("B19") Set crR = Intersect(crR.CurrentRegion, Range("B19:B29"), Range(crR, crR.End(xlDown))) '削除対象の途中に空白無いこと If crR.Rows.Count = 1 Then crR.Offset(1).Select MsgBox "削除する数字を入力ください" Exit Sub End If Set rlist = Range("B35") Set rlist = Range(rlist, rlist.End(xlDown)) Set rlist = Intersect(Range("B35:B300"), rlist).Resize(, 12) '在庫の途中の数字に空白無いこと rlist.AdvancedFilter xlFilterInPlace, crR, , False Set rrr = Intersect(rlist.Offset(1), rlist.SpecialCells(xlCellTypeVisible)) crR.Worksheet.ShowAllData If rrr Is Nothing Then MsgBox "すでに該当数字は全て削除されています" Exit Sub End If For i = rrr.Areas.Count To 1 Step -1 cnt = cnt + rrr.Areas(i).Rows.Count rrr.Areas(i).Delete xlShiftUp '該当範囲削除 Next Range("B301").Offset(-cnt).Resize(cnt, 12).Insert xlShiftDown '削除した分を下に挿入 crR.Select MsgBox cnt & " 件を削除しました" Intersect(crR, crR.Offset(1)).ClearContents End Sub
(kazuo) 2018/03/10(土) 20:21
検索するのはB列として
>一致したら、その行のBからМ列までを消して、上につめるマクロをおしえてください。
とのことですが、A列やM列以降が削除されるとまずいんでしょうか?
>エクセル初心者です。やさしくお願いします。
>マクロをおしえてください。
VBAについて基本的なことはわかってるとの理解でよいですか?
また、ある程度作ったものがあってどこかで詰まってるいるということでしょうか?
まったくの0から作ってくれとの仕事の丸投げであれば、私は対応する気がないので撤退します。
(もこな2) 2018/03/10(土) 22:48
こんばんはI 方法は色々あると思いますし、エラーも出ると思いますが、 後は、お勉強して頂くとして トピ主さんの >B10からB29までに、数値(1から999)を入れると、 >B36からB300までで一致する数値を探し(B列で検索)、 > 一致したら、その行のBからМ列までを消して、上につめるマクロをおしえてください。 の部分をコードにしてみました。 あっ、消すと検証するのが面倒だったので色を付けておきました。 まぁそこから改造して下さい。 私は一週間に一問程度しか回答出来ませんので、何かの参考になれば幸いです。 では、では、
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Range Dim v As Range Dim rr As Range Dim rrr As Range If Target.Count > 1 Then Exit Sub If Target.Value = "" Then Exit Sub If Intersect(Target, Range("B10:B29")) Is Nothing Then Exit Sub Application.EnableEvents = False For Each r In Range("B10:B29") If IsNumeric(r.Value) Then If Int(r.Value) = r.Value Then If (r.Value >= 1) * (r.Value <= 999) Then For Each v In Range("B36:B300") If v.Value = r.Value Then Set rr = v.Resize(, 12) If rrr Is Nothing Then Set rrr = rr Else Set rrr = Union(rr, rrr) End If End If Next End If End If End If Next Range("B36:M300").Interior.Color = xlNone If Not rrr Is Nothing Then rrr.Interior.Color = 65535 ' rrr.Delete End If Application.EnableEvents = True End Sub v(=∩_∩=)v (SoulMan) 2018/03/11(日) 00:06
こんにちは ^^ もこな2さん マナさん がアドバイスを kazuoさん SoulManさん が既にご呈示ですが、作ってみましたので何かの参考まで(ならないかもです^^;) 同じくあとは、お勉強して頂くとして。。。 Excel2004(MAc)無いので確認は出来ていません。?
Option Explicit '********************************************************** Sub main() Dim sh As Worksheet, sh01 As Worksheet Dim i As Long, j As Long, cnt As Long Dim r As Range, rr As Range, rrr As Range Set sh = ThisWorkbook.Worksheets("Sheet1") sh.Copy ActiveSheet.Name = Format(Now, "yyyymmdd-hhmmss") Set sh01 = Worksheets(ActiveWorkbook.Sheets(1).Name) Set r = sh01.Range("B10:B29") Set rr = sh01.Range("B36:M300") For i = 1 To rr.Rows.Count For j = 1 To r.Rows.Count If rr(i, 1) = r(j, 1) Then cnt = cnt + 1 If cnt = 1 Then Set rrr = sh01.Range(rr(i, 1), rr(i, 12)) Else Set rrr = Union(rrr, sh01.Range(rr(i, 1), rr(i, 12))) End If End If Next Next If Not rrr Is Nothing Then 'rrr.Delete shift:=xlShiftUp rrr.Select End If Set r = Nothing Set rr = Nothing Set rrr = Nothing Set sh01 = Nothing Set sh = Nothing End Sub (隠居じーさん) 2018/03/11(日) 07:48
並び替えは可能でしょうか?
並び替えてよければ、
不要なデータはクリアをして並び替えることで、
空白は下に追いやられるので、
対象範囲以外のセルに影響は出ないと思います。
(まっつわん) 2018/03/11(日) 10:28
A列やM列以降が削除されるとまずいんでしょうか?
わたしが前任から3月に引き継いだ表で、
A列やМ列に以降には、データや説明文などがはいっており、
勝手に削除できません。
マクロについては、少しかじった程度ですが、
最終行の取得法や、オフセットの使い方など、コードはある程度読み書きできます。
で、やってみたところ、Vlookupをワークシート関数として使用したり、find関数なども試したのですが、うまくいかず、質問したしだいです。
すいませんです。
マナさん、kazuoさん、もこな2さん、SoulManさん、隠居じーさんさん、まっつわんさん、
いろいろなアドバイスありがとうございます。
明日から会社で、別シートに書き出して、いろいろ実験してみます。
また、お聞きするかもしれません。
そのときはよろしくお願いいたします。
(佐竹ゆうこ) 2018/03/11(日) 12:49
Option Explicit
Sub test() Dim r As Range Dim c As Range Dim t As Range
Set r = Range("B35:M300") Set c = Range("ZZ1:ZZ2") c(2).Formula = "=countif($B$10:$B$29,B36)=0" Set t = c(1).Offset(, 1)
r.AdvancedFilter xlFilterCopy, c, t r.Value = t.Resize(r.Rows.Count, r.Columns.Count).Value c.CurrentRegion.ClearContents
End Sub
(マナ) 2018/03/11(日) 13:48
Option Explicit
Sub test()
Dim rng使用 As Range Dim rng在庫 As Range Dim c As Range
With ActiveSheet Set rng使用 = .Range("B10:M29") Set rng在庫 = .Range("B36:M300") End With
For Each c In rng使用.Columns(1).Cells Getデータ c Next With rng在庫 .Sort key1:=rngList(1), order1:=xlAscending, header:=xlNo End With End Sub
Private Function Getデータ(ByVal rngKey As Range, ByVal rngList As Range)
Dim ixRow As Long
On Error GoTo Wayout ixRow = WorksheetFunction.Match(rngKey, rngList, 0) On Error GoTo 0
With rngList.Rows(ix) .Copy rngKey .ClearContents End With
Wayout:
End Function
(まっつわん) 2018/03/11(日) 16:43
佐竹ゆうこさんへ
私のは B9 をB19 と書いたり他にも無駄がありますので無視してください。
(kazuo) 2018/03/11(日) 19:49
特に、フィルター関連のマクロでは
「まずは」手作業で試してとお願いしています。
で、その次の段階は、「マクロの記録」です。
なかなか、そういう展開にはなりませんが。
(マナ) 2018/03/11(日) 20:12
おそらく、マナさんは、2〜3の手動操作をマクロの記録を使ってどのような記述をすればよいのか調べてみては?ということを仰りたいのだとおもいますし、私も同じように思います。
それを踏まえて、以下蛇足です。
1のように、〇〇されたときに××するというのは、「イベント」というものがあります。
今回のケースで言えば、セルに入力された(=セルの内容が変更された)ことを条件にマクロを動かせばよいということになるので、Changeイベントが使えると思います。
たとえば、こんな感じ↓(シートモジュールに記述してください)
Private Sub Worksheet_Change(ByVal Target As Range)
'「Target」がB10〜B29の範囲でなければ終了 If Intersect(Target, Range("B10:B29")) Is Nothing Then Exit Sub
'「Target」が単一セルでなければ終了 If Target.Count > 1 Then Exit Sub
'「Target」の値がブランクなら終了 If Target.Value = "" Then Exit Sub
'「Target」の値が1〜999でなければ終了 Select Case Target.Value Case 1 To 999 MsgBox "B列が" & Target.Value & "になってる行を探して" & vbCrLf & _ "B〜M列を削除して、上方向にシフトしよう" Case Else '予定されている検索値でないので無視(=終了) Exit Sub End Select End Sub
2の作業は、Excel君が元々持っているフィルター機能をつかってあげたほうが高速動作するとおもいますが、あえて学習のため別方法を取るというのであれば、B36〜B300のセルを一つずつ条件に一致するのか見て、条件に一致した場合は、削除予定範囲に追加してやるというアプローチもあるとおもいます。
↓たとえば、こんな感じ
Sub Sample()
'==変数の宣言とか
Const 検索値 As Long = 123 '←テスト用 Dim i As Long Dim 最終行 As Long Dim MyRng As Range
'==処理
With ActiveSheet '最終行が36行未満であれば、データが無いと言うことだから終了 最終行 = .Cells(.Rows.Count, "B").End(xlUp).Row If 最終行 < 36 Then Exit Sub
'ループ処理で検索値に合致する行を取得する For i = 36 To 最終行 If .Cells(i, "B").Value = 検索値 Then If MyRng Is Nothing Then Set MyRng = .Rows(i) Else Set MyRng = Union(MyRng, .Rows(i)) End If End If Next i
If MyRng Is Nothing Then 'MyRngに何もセットされていないということは、合致する行が無かったのだから終了 Exit Sub Else Intersect(MyRng, .Columns("B:M")).Select'テスト用 'Intersect(MyRng, .Columns("B:M")).Delete (xlShiftUp)'コメントアウトを解除すれば問答無用で削除が発動します End If End With End Sub
↑コード中にもコメントつけてありますが、3は提示の条件だけであればそのまま削除すれば良いということになりますけど、運用面を考えた場合、数字を入力したら問答無用で削除するので、うっかり削除されたくない数字入力しちゃったらどうするのかちょっと心配になります。(マクロで実行したことは、「元に戻す」が使えません。)
以上、蛇足でした。
興味があったら研究材料にでもしてください。
(もこな2) 2018/03/12(月) 11:43
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.