- 締切済み
Excelで条件つき行削除について教えてください
前回に下記のような質問をしました。 「下記のようなExcelの表があるとします。 Ａ Ｂ Ｃ Ｄ Ｅ １ 会社A 会社B 会社C 会社D ２ 仕事A 23 45 67 27 ３ 仕事B 45 24 65 33 ４ 小計 68 69 132 60 この状態のときはいいのですが、 Ａ Ｂ Ｃ Ｄ Ｅ １ 会社A 会社B 会社C 会社D ２ 仕事A 0 0 0 0 ３ 仕事B 0 0 0 0 ４ 小計 0 0 0 0 このときに小計という文字を認識し、その横にある数字を認識し、その条件がすべて「0」だった場合に処理を行いたいです。」 この回答で、 「Sub 小計全部ゼロ_行非表示() Dim Rng As Range For Each Rng In Range("A1", Range("A65536").End(xlUp)) If Trim(Rng.Value) = "小計" And _ Rng.Offset(, 1) = 0 And Rng.Offset(, 2) = 0 And _ Rng.Offset(, 3) = 0 And Rng.Offset(, 4) = 0 Then Rng.EntireRow.Hidden = True End If Next Rng End Sub」 このような回答がありました。 私は「小計」がＣ列にあり、「0」を検索したいのがＦ、Ｇ、Ｈ、Ｉにあります。 条件に合うように変更したのですがエラーが出てしまいます。 分かる方いましたら教えてください。」よろしくお願いします。
- taws
- お礼率16% (46/279)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
みんなの回答
- S-Fuji
- ベストアンサー率36% (592/1624)
そこまで回答を貰ったのでしたら、ご自分でも意味合いを考えましょう。 ヒント そのプログラムは、「小計」はA列に有る事、データがB・C・D・E列に有る事を前提に作られています。 VBAにおけるOffsetの意味を調べましょう。 http://homepage1.nifty.com/kenzo30/index.htm http://www.fuji.ne.jp/~excelyou/index.htm
関連するQ&A
- エクセルVBAで表から行の削除
添付画像のような表があります。 表はB列の名前でソートされています。 D列の比率をみて、100でないものは、必ず同じ名前で複数行にわかれ合計で100になります。この例では名前CとEとHがそうです。 同じ名前が複数行にわかれている場合、最大の比率の行を残し、他の行（例では、埼玉、栃木、長野、新潟の行）を削除したいのです。 複数行にわかれるのが名前CやEのように2行なら、以下のコードで出来ました。 しかし、めったにはありませんが名前Hのような3行以上に分かれるものには対応できません。 どうすればよいでしょうか？ Sub test01() Dim c As Range Dim Rng As Range Set Rng = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp)) For Each c In Rng '2地区の分担の場合、分担比率高い方を残す。（3地区以上は未対応）2012/08/29 If c.Value <> 100 And c.Offset(1).Value <> 100 Then If c.Offset(, -2).Value = c.Offset(1, -2).Value Then If c.Value >= c.Offset(1).Value Then c.Offset(1).Value = False Else c.Value = False End If End If End If Next If Application.WorksheetFunction.CountIf(Rng, False) > 0 Then Rng.SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete End If End Sub
- ベストアンサー
- その他MS Office製品
- エクセル VBA の質問です。
A2～A20までのセルに文字を入力した段階で、それぞれB2～B20に入力日時を入れるVBAを以下のように組んでいます。 しかし、同様の条件を同一シートのE2～E20・F2～F20にも入力・自動表示できるようにしなければならなくなり、困っています。 どのように記述を変えればよいのか、教えていただけたらと思います。 宜しく御願いいたします。 Sub Worksheet_change(ByVal Target As Range) Dim Rng As Range Dim c As Range Set Rng = Range("A2:A20") If Intersect(Target,Rng) Is Nothing Then Exit Sub For Each c In Intersect(Target,Rng) If Not IsEmpty(c) Then c.Offset(, 1).Value = Now Else c.Offset(, 1).ClearContents End If Next Rng.Offset(, 1).EntireColumn.AutoFit End Sub 申し訳ありませんが、何卒、宜しく御願いいたします。
- ベストアンサー
- オフィス系ソフト
- Excelで条件つき行削除について
下記のようなExcelの表があるとします。 Ａ Ｂ Ｃ Ｄ Ｅ １ 会社A 会社B 会社C 会社D ２ 仕事A 23 45 67 27 ３ 仕事B 45 24 65 33 ４ 小計 68 69 132 60 この状態のときはいいのですが、 Ａ Ｂ Ｃ Ｄ Ｅ １ 会社A 会社B 会社C 会社D ２ 仕事A 0 0 0 0 ３ 仕事B 0 0 0 0 ４ 小計 0 0 0 0 上記のようにＢ４、Ｃ４、Ｄ４、Ｅ４がそれぞれ「０」のときに４行目を削除または行の高さを「０」にするマクロを組みたいです。 わかる方がいましたらよろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセル 2010 マクロ 検索
http://okwave.jp/qa/q8562170.html 上記質問に追加です。 ※1 'D,E,F,G,H,I,K を検索してD,E,F,G,H,I に検索対象があった時 E,F,G,H,Iのいずれかだったら左横列の上に向かって (EならD 、FならE ・・・という具合に) 何か入力されているセルのM列の191000####をmsgboxで表示させたいです。 (画 F11セル(A-1)が検索ヒットした場合E9セル(R-01)を辿り、 その行のM列のセル(191000####)をmsgboxで表示 ※2 但し、検索結果がD列のデータだった時、その行のM列が191000####だった場合 M列の191000####をmsgboxで表示させたいです。 (画 D25セル(Y-1)対象の時) ※3 また、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合 (空白だったり191000####以外の場合) M列の一番上の191000####をmsgboxで 191000####&「これは例外です」と表示させたいです。 (画 D24セル (X-1)対象の時) 現在のコードは下記のとおりです。 Sheet1に Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> "$A$3" Then Exit Sub Call 検索 Range("A1:A2").Clear Range("A1").Activate End Sub 標準モジュールに Sub 検索() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim strKey As Variant Dim s As String Dim c As Range, bln As Boolean Dim rng1 As Range Dim cnt As Long Set Ws1 = Sheet1 Set Ws2 = Sheet2 Ws1.Select With Ws2 strKey = Application.Transpose(.Range("A1").Resize(2).Value) strKey = Join(strKey, "") End With If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub With Ws1 Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp)) For Each c In rng1.Offset(, -10) 'D,E,F,G,H,I,Kを検索 s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 8).Value & c.Offset(0, 10).Value & If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then c.End(xlToRight).Activate c.Offset(0, 2).Value = Date c.Resize(1, 14).Interior.ColorIndex = 6 bln = True Exit For End If Next c If Not bln Then Ws2.Select MsgBox "リストに存在しません", vbExclamation, "NotFound" Else '加える Call ReSearch(Ws1.Range("M2"), c.Row) '再設定 Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp)) MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation End If End With Application.Goto Ws2.Range("A1"), True End Sub Sub ReSearch(Rng As Range, j As Long) '最初のセル, 終わりの行数 Dim i As Long Dim Ws As Worksheet With Rng.Parent For i = j To Rng.Row Step -1 If CStr(.Cells(i, Rng.Column).Value) Like "191000####" Then MsgBox "指図番号 " & vbCrLf & CStr(.Cells(i, Rng.Column).Value) & " の部品です" Exit For End If Next i End With End Sub Function DoubleCountBlank(rng1 As Range, rng2 As Range) '横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2) Dim i As Long Dim cnt As Long For i = 1 To rng1.Rows.Count If VarType(rng2.Cells(i, 1)) = vbDouble Then If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then cnt = cnt + 1 End If End If Next i DoubleCountBlank = cnt End Function 宜しくお願い致します。
- ベストアンサー
- Excel（エクセル）
- 条件に合った行を削除するマクロについて
こんにちは 今、現在、とある条件にあった行を削除するマクロ作っているのですが、 インターネットを調べてみると後ろから探索して、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
- Excelの目次作成のマクロ
Excel 2000 で本の目次を作りたいと、思いネットで下記ののようなマクロを見つけました。 Sub 索引作成() Dim R As Range, R2 As Range, LastFound As Range Dim Found As Boolean Range("C2", Range("D65536").End(xlUp).Offset(1, 0)).Clear For Each R In Range("A2", Range("A65536").End(xlUp)) Found = False Set LastFound = Range("C65536").End(xlUp) For Each R2 In Range("C2", LastFound) If R2.Value = R.Value Then R2.Offset(0, 1).Value = R2.Offset(0, 1).Value & "," & R.Offset(0, 1).Value Found = True End If Next If Found = False Then LastFound.Offset(1, 0) = R.Value LastFound.Offset(1, 1) = R.Offset(0, 1).Value End If Next End Sub このマクロを使うと下記のような結果になるのですが、頁数の桁が多い場合（1000ページ以上）や、項目名の重複が多い場合は上手く動きません。 A B C D 項目名 頁 A 1 B 2 C 3 D 4 A 5 B 6 C 7 D 8 ↓上記マクロを使うと A B C D 項目名 頁 A 1 A 1,5 B 2 B 2,6 C 3 C 3,7 D 4 D 4,8 A 5 B 6 C 7 D 8 となりますが、頁が1000桁以上になると A B C D 項目名 頁 A 1000 A 100,010,04 B 1001 B 100,110,05 C 1002 C 100,210,06 D 1003 D 100,310,07 A 1004 B 1005 C 1006 D 1007 のようになります。 頁が1000桁以上になる場合や、項目名の重複が多くなる場合でも上手く動くマクロは無いものでしょうか。 何卒、宜しくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- エクセル 最終行からの連続コピー
* すぐに回答を！ エクセルC20からI51までデータを１日１行ずつ入力します。 データが入力されている最終行から上に連続する１０行（最終行含む）をコピーしたいのですが、最終行から10行上をどのように認識させたらいいのか、わかりません。Offsetなど試してみましたがダメでした。 よろしくお願いします。 Sub dataコピー() Dim i As Long Dim j As Integer Dim rng As Range '最後尾から10行前までを選択 With Worksheets("月").Range(Cells(20, 3), Cells(51, 10)) For i = Cells(Rows.Count, 1).End(xlUp).Row To -10? If rng Is Nothing Then Set rng = .Rows(i) End If j = j + 1 If j >= 10 Then Exit For Next i 'コピー If Not rng Is Nothing Then rng.Copy Range("M1") Beep Else MsgBox "該当行は存在しません。", 48 End If End With Set rng = Nothing End Sub コードはこちらを参考にしました http://questionbox.jp.msn.com/qa5440189.html
- 締切済み
- オフィス系ソフト
- VBAの記録を追加したい
エクセル2002使用です。 VBAで次のコードを使っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Set Target = Intersect(Range("C:C"), Target) If Target Is Nothing Then Exit Sub For Each Rng In Target If Rng.Value <> "" Then Rng.Offset(, -2).Value = Now Else ' (*) Rng.Offset(, -2).Value = "" ' (*) End If Next Rng End Sub （C列のセルに何か入力されると、A列の同じ行にその時刻が入る。） 同じシートで、F列に何か入力されるとE列の同じ行にその時刻が入るように書き直したいのですが、どうすればいいのでしょうか？ すいませんが、よろしくお願いします。
- ベストアンサー
- Visual Basic
- Excelマクロについて
先日、OKWEBで教えてもらったマクロに手を加えて作ろうとしたのですが、エラーがでて動かなくなりました。 わかる方がいましたら教えてください。 よろしくおねがいします。 Sub 見積書() Application.ScreenUpdating = False '見積書(完成)シートを選択 Sheets("見積書(完成)").Select '行の高さを「15」にする。 Rows("6:67").Select Range("F6").Activate Selection.RowHeight = 15 'S列のS6:S56をコピーしてE6:E7に貼り付ける。 Range("S6:S56").Select Selection.Copy Range("E6:E7").Select ActiveSheet.Paste '5列目(工数)が「0」のとき該当する行の高さを「0」にする。 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 If Cells(i, 5).Value = "0" And Cells(i, 7).Value = "0" Then Rows(i).RowHeight = 0 End If Next '「E8:E55」の範囲を四捨五入する。 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 Range("E8:E55") = Application.Round(Range("E8:E55"), 0) '工数を四捨五入 Next 'C列の中に含まれる「小計」を検索しそこから6列目が「0」だったら行の高さを「0」にする。 Dim Rng As Range Const Retu = "C" For Each Rng In Range(Retu & "1", Range(Retu & "100").End(xlUp)) If Trim(Rng.Value) = "小 計" And _ Rng.Offset(, 6) = 0 Then Rng.EntireRow.Hidden = True End If Next Rng End Sub
- 締切済み
- オフィス系ソフト
- エクセル 数値結果の値によって日付を入れたい
シート2の2列目にOKが入ると、シート１のC列にOKが入り、更新された日がB列に表示されるようにしたいです。 C列に手入力でOKと入力すればB列に日付が表示されるのですが、C列をVLOOKで呼ぶようにしたら表示されなくなってしまいました。 どのように修正していいのか分かりません。 お教えいただければと思います。よろしくお願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Dim TgRng As Range Set TgRng = Intersect(Range("C1:C2000"), Target) If Not TgRng Is Nothing Then Application.EnableEvents = False For Each Rng In TgRng If Rng.Value = "OK" Then Rng.Offset(, -1).Value = Date End If Next Application.EnableEvents = True End If Set TgRng = Nothing End Sub
- ベストアンサー
- Excel（エクセル）
