Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1704 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【72645】検索値以外を全て削除したい はってんちゅう 12/8/30(木) 15:26 質問[未読]
【72647】Re:検索値以外を全て削除したい UO3 12/8/30(木) 15:49 発言[未読]
【72648】Re:検索値以外を全て削除したい ドカ 12/8/30(木) 16:29 回答[未読]
【72649】Re:検索値以外を全て削除したい はってんちゅう 12/8/30(木) 17:07 質問[未読]
【72650】Re:検索値以外を全て削除したい UO3 12/8/30(木) 17:26 発言[未読]
【72652】Re:検索値以外を全て削除したい はってんちゅう 12/8/30(木) 20:02 お礼[未読]
【72651】Re:検索値以外を全て削除したい ドカ 12/8/30(木) 17:46 発言[未読]
【72653】Re:検索値以外を全て削除したい はってんちゅう 12/8/30(木) 20:14 お礼[未読]
【72645】検索値以外を全て削除したい
質問  はってんちゅう  - 12/8/30(木) 15:26 -
引用なし
パスワード
   検索＆削除のモジュールに関してです。

先日、UO3さんから検索対象の削除モジュールでアドバイスを頂き
無事解決したのですが、今度は検索対象以外のものすべてを削除するモジュールを
書いています。

以下がそれです。
コラムA にある科目名を頼りに“投資”以外の科目の行を全て削除させる目的です。10行目から科目が入るRowになります。

　　Range("A10").Select
　　m = 10
　　Do Until Range("A" & m) = ""
　　　　If Not Range("A" & m) = "投資" Then
　　　　　　Rows(m).Delete
　　　　End If
　　　　　　m = m + 1
　　Loop

50行ほどあるのですが、これだと、全削除されずにかなり残ってしまいます。
なんとなくそうなるダメな理由が解るような気がするものの、どうしていいのかが
解りません。

以下は、検索対象を削除するモジュールですが、これの反対（検索対象以外を削除）版を行いたいわけです。

Dim cNo As Range
Dim myR As Range
Dim firstaddress As String

　　With Worksheets(2).Range("A9:AZ9")
　　　　Set cNo = .Find("投資", LookIn:=xlValues, SearchOrder:=xlByRows)
　　
　　　　If Not cNo Is Nothing Then
　　　　　　firstaddress = cNo.Address
　　　　　　Do
　　　　　　　　If myR Is Nothing Then
　　　　　　　　　　Set myR = cNo
　　　　　　　　Else
　　　　　　　　　　Set myR = Union(myR, cNo)
　　　　　　　　End If
　　　　
　　　　　　　　Set cNo = .FindNext(cNo)
　　　　
　　　　　　Loop While cNo.Address <> firstaddress
　　　
　　　　End If
　　
　　　　If Not myR Is Nothing Then myR.EntireRow.Delete
　　
　　End With


これを上手く活用する事も出来るのでしょうが、上手くいきません。

どうぞご教示いただけますでしょうか。
宜しくお願い致します。
【72647】Re:検索値以外を全て削除したい
発言  UO3  - 12/8/30(木) 15:49 -
引用なし
パスワード
   ▼はってんちゅう さん：

▼はってんちゅう さん：

こんにちは

姑息な（？）手段としては、
・抽出された状態で、コピーしてこのシートのリスト領域の右側にペースト。
・その上で、現在のリスト領域の列を削除。

これでもいいのかなと思います。

まっとうにコード処理するとすれば以下はサンプルです。
Sheet1にオートフィルターを設定して、何か、抽出された形にして実行してみてください。

Sub Sample()
　　'オートフィルターで抽出されていない行を削除する
　　Dim c As Range
　　Dim r As Range
　　
　　For Each c In Sheets("Sheet1").AutoFilter.Range.Columns(1).Cells
　　　　If Intersect(c, Sheets("Sheet1").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)) Is Nothing Then
　　　　　　If r Is Nothing Then
　　　　　　　　Set r = c
　　　　　　Else
　　　　　　　　Set r = Union(r, c)
　　　　　　End If
　　　　End If
　　Next
　　
　　If Sheets("Sheet1").FilterMode Then Sheets("Sheet1").ShowAllData
　　If Not r Is Nothing Then r.EntireRow.Delete
　　
End Sub
【72648】Re:検索値以外を全て削除したい
回答  ドカ  - 12/8/30(木) 16:29 -
引用なし
パスワード
   ▼はってんちゅう さん：
Sub test1()

For i = 100 To 10 Step -1
　　If Cells(i, 1) = "投資" Then
　　Else
　　　　Rows(i).Delete
　　End If
Next
End Sub
【72649】Re:検索値以外を全て削除したい
質問  はってんちゅう  - 12/8/30(木) 17:07 -
引用なし
パスワード
   ▼ドカ さん：

ありがとうございます。

ついでで申し訳ないのですが、
検索Findを使用するときの指定要因で、検索用語が完全一致であることを指定するには、どういう文言が必要なのでしょうか。調べても見つからず困っています。

教えていただけますでしょうか。

以下は、“当期純損益金額”という言葉のある行の2行下にコピーしているものを
貼り付ける事を書いたものです。
他にもこの言葉が入った用語があり、現在のモジュールはそれを選択してしまっています。
言葉の完全一致を指定したいです。

　　Range("A10").Select　　'投資残の表を損益外貨表の下に貼り付け
　　Range(Selection, Selection.End(xlDown)).Select
　　Range(Selection, Selection.End(xlToRight)).Select
　　Selection.Copy
　　Sheets(2).Select
　　With Worksheets(2).Range("a10:a50")
　　　　Set u = .Find("当期純損益金額", LookAt:=xlPart, LookIn:=xlValues, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=True)
　　firstaddress = u.Address
　　Range("A" & u.Row + 2).Select
　　ActiveSheet.Paste
　　End With

宜しくお願い致します。
【72650】Re:検索値以外を全て削除したい
発言  UO3  - 12/8/30(木) 17:26 -
引用なし
パスワード
   ▼はってんちゅう さん：

こんにちは

>検索Findを使用するときの指定要因で、検索用語が完全一致であることを指定するには、どういう文言が必要なのでしょうか。

LookAt:=xlPart　--->　LookAt:=xlWhole

ですね。
【72651】Re:検索値以外を全て削除したい
発言  ドカ  - 12/8/30(木) 17:46 -
引用なし
パスワード
   ▼はってんちゅう さん
私なんか何も知りませんが、ネットで　”VBA　find”　で検索すれば、最初に答えが出てきますよ。
【72652】Re:検索値以外を全て削除したい
お礼  はってんちゅう  - 12/8/30(木) 20:02 -
引用なし
パスワード
   ▼UO3 さん：

また助けていただいてありがとうございます！
【72653】Re:検索値以外を全て削除したい
お礼  はってんちゅう  - 12/8/30(木) 20:14 -
引用なし
パスワード
   ▼ドカ さん：

ありがとうございます。もう一度見てみます。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1704 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free