Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


2597 / 13645 ツリー ←次へ | 前へ→

【66975】AutoFilter以外の方法 にしもり 10/10/22(金) 16:03 質問[未読]
【66976】Re:AutoFilter以外の方法 kanabun 10/10/22(金) 16:57 発言[未読]
【66978】Re:AutoFilter以外の方法 momo 10/10/22(金) 18:01 発言[未読]
【66983】Re:AutoFilter以外の方法 kanabun 10/10/22(金) 19:20 発言[未読]
【67003】Re:AutoFilter以外の方法 momo 10/10/25(月) 15:17 発言[未読]
【67005】Re:AutoFilter以外の方法 kanabun 10/10/25(月) 18:31 発言[未読]
【66977】Re:AutoFilter以外の方法 Hirofumi 10/10/22(金) 17:03 発言[未読]
【66979】Re:AutoFilter以外の方法 にしもり 10/10/22(金) 18:28 質問[未読]
【66980】Re:AutoFilter以外の方法 Hirofumi 10/10/22(金) 18:43 回答[未読]
【66981】Re:AutoFilter以外の方法 Hirofumi 10/10/22(金) 18:55 回答[未読]
【66982】Re:AutoFilter以外の方法 kanabun 10/10/22(金) 19:17 発言[未読]
【66984】Re:AutoFilter以外の方法 ponpon 10/10/22(金) 19:38 発言[未読]
【66995】Re:AutoFilter以外の方法 にしもり 10/10/24(日) 21:12 お礼[未読]

【66975】AutoFilter以外の方法
質問  にしもり  - 10/10/22(金) 16:03 -

引用なし
パスワード
   こんいちは。
下記のようにB列にshohinをタイトルとして
apple,orangeというレコードがあるとします。
いまorangeというレコードを完全に取り去ってappleだけにしたいのですがAutoFilterしか思いつきません。ですがAutoFilterですと、フィルターを解除したときorangeというレコードが再び表出されてしまい、希望どおりではありません。
orangeというレコードを完全に取り去るロジックをどなたかご教示ください。

すみません、不勉強でいまだにvbaというものがわかっていません。。

Sub Macro1()

  Range("B1").Select
  ActiveCell.FormulaR1C1 = "shohin"
  Range("B2").Select
  ActiveCell.FormulaR1C1 = "apple"
  Range("B3").Select
  ActiveCell.FormulaR1C1 = "apple"
  Range("B4").Select
  ActiveCell.FormulaR1C1 = "orange"

  ActiveSheet.Range("B1").AutoFilter Field:=1, Criteria1:="<>orange", _
    Operator:=xlAnd
End Sub

【66976】Re:AutoFilter以外の方法
発言  kanabun  - 10/10/22(金) 16:57 -

引用なし
パスワード
   ▼にしもり さん:

>orangeというレコードを完全に取り去る

レコード数が1000位までなら、

>  ActiveSheet.Range("B1").AutoFilter Field:=1, Criteria1:="<>orange", _
>    Operator:=xlAnd

でなく、削除したい "orange"を抽出して、行削除する手があります。

Sub Delete_orange()
 Dim r As Range

 Set r = Range("B1", Cells(Rows.Count, 2).End(xlUp))
 r.Worksheet.AutoFilterMode = False
 r.AutoFilter 1, Criteria1:="orange" '削除したいアイテム
 If r.SpecialCells(xlVisible).Count > 1 Then
   Intersect(r, r.Offset(1)).EntireRow.Delete
 End If
 r.AutoFilter

End Sub

レコードが5000とか多いと、「フィルタオプションの設定」で
別シートに抽出したほうが速いですけど。

【66977】Re:AutoFilter以外の方法
発言  Hirofumi  - 10/10/22(金) 17:03 -

引用なし
パスワード
   B列をKeyとしてListを整列
orangeが下に集まるので、orange先頭行から最終行までを削除
でも出来るのでは?

【66978】Re:AutoFilter以外の方法
発言  momo  - 10/10/22(金) 18:01 -

引用なし
パスワード
   こんな方法も・・・

Sub test()
With Range(Range("B2"), Range("B2").End(xlDown))
 .ColumnDifferences(.Find(What:="apple", LookAt:=xlWhole)) _
   .EntireRow.Delete
End With
End Sub

【66979】Re:AutoFilter以外の方法
質問  にしもり  - 10/10/22(金) 18:28 -

引用なし
パスワード
   ▼kanabun さん HIrofumiさん
まことにありがとうございます。
レコードは5000はないのですが、毎日おこなう予定なので手でなくマクロで行削除したいです。

momoさん、
大変参考になります。
情報不足ですみませんでしたが、消したいのはorangeだけですが、
残したいのはappleだけでなくbananaとか他にもあります。
そこで下記にようにしたらcompileはできましたが、実行エラーになりました。


Sub test()
With Range(Range("B2"), Range("B2").End(xlDown))
 .ColumnDifferences(.Find(What:="apple", What:="banana", LookAt:=xlWhole)) _
   .EntireRow.Delete
End With
End Sub

わたくしの意図通りに走らす書き方はありますでしょうか。

【66980】Re:AutoFilter以外の方法
回答  Hirofumi  - 10/10/22(金) 18:43 -

引用なし
パスワード
   'では、こんなのでは?
'先頭行は列見出しとします

Option Explicit

Public Sub Sample_2()

  'Listのデータ列数(B列)
  Const clngColumns As Long = 1
  'Keyと成る列位置(基準セルからの列Offsetで指定:B列 = 0)
  Const clngKey As Long = 0
  'Keyと成る文字列
  Const cstrKey As String = "orange"
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngCount As Long
  Dim rngList As Range
  Dim lngNumb() As Long
  Dim vntKeys() As Variant
  Dim strProm As String
  
  Dim sngTime1 As Single
  Dim sngTime2 As Single
  
  sngTime2 = Timer

  'Listの先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngList = ActiveSheet.Range("B1")

  'Listに対しての前処理
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'L列の値を配列として取得
    vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
  End With
  
  '削除用整列Keyを格納する配列を確保
  ReDim lngNumb(1 To lngRows, 1 To 1)
  
  'List最終行まで繰り返し
  For i = 1 To lngRows
    'L列の値が"Kg"でないなら
    If StrComp(vntKeys(i, 1), cstrKey, vbTextCompare) <> 0 Then
      'R列の値をEmptyに(削除行)
      lngNumb(i, 1) = 1
      '削除行をカウントする
      lngCount = lngCount + 1
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '削除行が有るなら
    If lngCount > 0 Then
      If MsgBox(lngCount & "件が該当します、削除しますか?", _
          vbYesNo + vbInformation) = vbYes Then
        'List最終列の後ろ列(R列)に削除Flagを出力
        .Offset(1, clngColumns).Resize(lngRows).Value = lngNumb
        'Listを削除Flag昇順、復帰Key昇順で整列
        DataSort .Offset(1).Resize(lngRows, clngColumns + 1), .Offset(1, clngColumns)
        '不要データを削除
        .Offset(lngRows - lngCount + 1).Resize(lngCount).EntireRow.Delete
        '復帰用Keyと削除Flagを消去
        .Offset(, clngColumns).EntireColumn.ClearContents
        strProm = lngCount & "件を削除しました"
      Else
        strProm = "削除を中止しました"
      End If
    Else
      strProm = "該当行は在りません"
    End If
  End With
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
   
  sngTime1 = Timer
  
  MsgBox strProm & vbLf & (sngTime1 - sngTime2), vbInformation
  
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngSortOrder As Long = xlAscending, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=lngSortOrder, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

【66981】Re:AutoFilter以外の方法
回答  Hirofumi  - 10/10/22(金) 18:55 -

引用なし
パスワード
   ごめん、別の事で作った物を転用したので
指定文字列以外の物を削除するに成っていました
以下の★印に変更して下さい

    'L列の値が"Kg"でないなら
'    If StrComp(vntKeys(i, 1), cstrKey, vbTextCompare) <> 0 Then
    If StrComp(vntKeys(i, 1), cstrKey, vbTextCompare) = 0 Then '★変更

また、コメントも前の物ですので読み替えて下さい

【66982】Re:AutoFilter以外の方法
発言  kanabun  - 10/10/22(金) 19:17 -

引用なし
パスワード
   ▼にしもり さん:
>▼kanabun さん HIrofumiさん
>レコードは5000はないのですが、毎日おこなう予定なので手でなくマクロで行削除したいです。

試してはいないのですが、
5000行くらいなら、

>  r.AutoFilter 1, Criteria1:="orange" '削除したいアイテム
>  If r.SpecialCells(xlVisible).Count > 1 Then
>   Intersect(r, r.Offset(1)).EntireRow.Delete
>  End If

で行けるのではないかと思います。

【66983】Re:AutoFilter以外の方法
発言  kanabun  - 10/10/22(金) 19:20 -

引用なし
パスワード
   ▼momo さん:

>こんな方法も・・・
>
>Sub test()
>With Range(Range("B2"), Range("B2").End(xlDown))
> .ColumnDifferences(.Find(What:="apple", LookAt:=xlWhole)) _
>   .EntireRow.Delete
>End With
>End Sub

なるほどです。
ところで、この方法のばあい、SpecialCellsと同様のArea数の制限が
あるようですね?
制限を超えたときにはすべての行が削除されました。

【66984】Re:AutoFilter以外の方法
発言  ponpon  - 10/10/22(金) 19:38 -

引用なし
パスワード
   私も考えてみました。

Option Explicit
Sub test()
  Dim myR As Range

  Set myR = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp))
  With myR.Offset(, 36)
     .Formula = "=IF(B1=""orenge"",1,"""")"
     On Error Resume Next
     .SpecialCells(3, 1).EntireRow.Delete
     On Error GoTo 0
     .Delete
  End With
End Sub

【66995】Re:AutoFilter以外の方法
お礼  にしもり  - 10/10/24(日) 21:12 -

引用なし
パスワード
   ▼ponpon さん Hirofumiさん kanabunさん:

皆さまどうもありがとうございます。
Hirofumiさんのサジェスチョンは、正直私には高度すぎて十分理解できませんでした。でもありがとうございます。kanabunさんかponponさんのサジェスチョンを参考にさせていただきたいと思います。ponponさんのOffsetを用いるほうは動作確認したらうごきました。深謝いたします。

【67003】Re:AutoFilter以外の方法
発言  momo  - 10/10/25(月) 15:17 -

引用なし
パスワード
   ▼kanabun さん:
こんにちは。 こちらでは初めてです。

エリア数制限はそのようですね。
でも意外と便利な方法なのでよく使います。

抽出などのときでもAutoFilterの手続きが面倒な時には
全部CurrentRegionでコピーしてから、この方法で特定行だけにしてしまうなど。

あんまり8000エリアとかになるようなデータは扱わないので・・・^^;

【67005】Re:AutoFilter以外の方法
発言  kanabun  - 10/10/25(月) 18:31 -

引用なし
パスワード
   ▼momo さん:
コメント ありがとうございます。

>エリア数制限はそのようですね。
>でも意外と便利な方法なのでよく使います。
>
>抽出などのときでもAutoFilterの手続きが面倒な時には
>全部CurrentRegionでコピーしてから、この方法で特定行だけにしてしまうなど。

了解です〜
ぼくもこれからは利用させていただきます♪


2597 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free