人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excelの質問です。A列から2つのキーワードを含むセルを行毎、別シートに移動させたいです。

今、Sheet1のA列からZ列に、6万行ほどのデータがあります。
最初に、A列で“りんご”というキーワードを含むセルを検索しまして。
該当するセルが、例えば1200セルあったとしましたら。
そのセルを含む行まるごと、1200行をSheet2に移動させます。

次に“ごりら”というキーワードで、同じくA列を検索しまして。
該当するセルが、例えば500セルあったとしましたら。
そのセルを含む行まるごと、500行を、最初に移動させた1200行の真下(1201行目)に、加えます。

そのような作業をマクロなどで実現できないでしょうか。
よろしくお願い致します。

●質問者: moon-fondu
●カテゴリ:インターネット 学習・教育
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● hathi
●100ポイント

このようなのでも、加工すると、使えるかもしれません。


Sub Macrowawa()
wawa = Sheets("Sheet1").Range("$A$15").CurrentRegion.Address
Stop ' wawaは適当 A15は適当(データのある行)
Sheets("Sheet1").Range(wawa).AutoFilter Field:=1, Criteria1:="hgYY4.3"
Stop ' hgYY4.3は、「りんご」「まぐろ」などの抽出するもの
Sheets("Sheet1").Range(wawa).CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A2")
Stop ' A2は、貼り付ける先の左上端
Sheets("Sheet1").Range(wawa).AutoFilter Field:=1
End Sub


moon-fonduさんのコメント
ご回答ありがとうございます。 うーん、 Sub Macrowawa() wawa = Sheets("Sheet1").Range("A1:60000").CurrentRegion.Address Stop ' wawaは適当 A15は適当(データのある行) Sheets("Sheet1").Range("A1:A60000").AutoFilter Field:=1, Criteria1:="りんご" Stop ' hgYY4.3は、「りんご」「まぐろ」などの抽出するもの Sheets("Sheet1").Range("A1;60000").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A2") Stop ' A2は、貼り付ける先の左上端 Sheets("Sheet1").Range("A1;60000").AutoFilter Field:=1 End Sub にしてみたのですが・・・2行目でオブジェクトの定義エラーになってしまいました。

hathiさんのコメント
例えば次のように直して実行してみてください。 wawa = Sheets("Sheet1").Range("A1:60000").CurrentRegion.Address ↓ wawa = Sheets("Sheet1").Range("A1:A60000").CurrentRegion.Address Sheets("Sheet1").Range("A1;60000").CurrentRegion.Copy Destination:=Sheets("Sheet2") ↓ Sheets("Sheet1").Range("A1:A60000").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A2") Sheets("Sheet1").Range("A1;60000").AutoFilter Field:=1 ↓ Sheets("Sheet1").Range("A1:A60000").AutoFilter Field:=1 なお、Stop とかいてある行は、行そのものがないのが普通のやり方です。 例でStopの行があるのは、その直前の動作でシートがどのようになったのかを目で確認するためだけです。 「;」と「:」とでは違います。 アドレスの表記方法は決まったやり方をする必要があります。 また、仮に60000行まである場合でも、1234行までの場合でも、このような連続した範囲を対象にして動作させるためであれば、「.CurrentRegion」の指定で十分です。 また、 wawa = Sheets("Sheet1").Range("A1").CurrentRegion.Address と書くことで、この行を実行したときに、 「wawa」は、A1を含む何かの記入がなされてる連続したすべての範囲になります。 例えば、wawaは、$A$1:$M$63265 というアドレスを記憶します。 そうなので、次のコードでも、結果は同じです。 Sub Macrowawar0() wawa = Sheets("Sheet1").Range("A1").CurrentRegion.Address Sheets("Sheet1").Range(wawa).AutoFilter Field:=1, Criteria1:="りんご" Sheets("Sheet1").Range(wawa).CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A2") Sheets("Sheet1").Range(wawa).AutoFilter Field:=1 End Sub もちろん wawaなどいい加減な名前を使うのではなく、myAreaのようにした方が、格好がましになります。 これでも、結果は同じです。 Sub SampleX() Sheets("Sheet1").Range("A1").AutoFilter Field:=1, Criteria1:="りんご" Sheets("Sheet1").Range("A1").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A2") Sheets("Sheet1").Range("A1").AutoFilter Field:=1 End Sub

moon-fonduさんのコメント
ご回答ありがとうございます!返信が遅くなりまして、大変申し訳ございません<m(__)m> すみません、Aが抜けておりました・・・。 hathiさんのマクロを参考に修正・実行してみたのですが、 Stop ' wawaは適当 A15は適当(データのある行) の箇所で、マクロが[中断]してしまうのです。 中断せずに、目的のデータをsheet1からsheet2に移動できたらいいのですが…。

hathiさんのコメント
前に補足で書いたように、 「 なお、Stop とかいてある行は、行そのものがないのが普通のやり方です。 例でStopの行があるのは、その直前の動作でシートがどのようになったのかを目で確認するためだけです。 」 当然に 次のようになります。 「 Stop ' wawaは適当 A15は適当(データのある行) の箇所で、マクロが[中断]してしまうのです。 」 前に補足したように、 次で動きます。 「 Sub SampleX() Sheets("Sheet1").Range("A1").AutoFilter Field:=1, Criteria1:="りんご" Sheets("Sheet1").Range("A1").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A2") Sheets("Sheet1").Range("A1").AutoFilter Field:=1 End Sub 」 上記の「 Sub SampleX() ~~~~~ End Sub 」が動く前提は、 ? Sheet1のA1から連続して各セルに何かのデータが入っていること ? Sheet2には、(マクロ実行の前のときには)なにも記載がないこと ? Sheet1のA列のデータの中には"りんご"というセルが一つはあること です。 上記の「 Sub SampleX() ~~~~~ End Sub 」で、マクロは、中断せずに、目的のデータをsheet1からSheet2に転写して、Sheet1のすべての行を(元に戻すように)表示して、終了します。 Sheets("Sheet1").Range("A1").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A2") を Sheets("Sheet1").Range("A1").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A1")にすれば、Sheet2の転写先頭位置は1行目になり、 Sheets("Sheet1").Range("A1").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A8")にすれば、Sheet2の転写先頭位置は8行目になります。

moon-fonduさんのコメント
ご回答ありがとうございます。 該当データを1つだけSheet2に移動させることができました。 該当データ全てを移動できたらいいのですが…。

hathiさんのコメント
済みませんでした。 下のではどうでしょうか。 Sub SampleXY() With Sheets("Sheet1").Range("A1") .AutoFilter Field:=1, Criteria1:="リンゴ" .CurrentRegion.Copy Sheets("Sheet2").Range("A2") End With End Sub

moon-fonduさんのコメント
うーん、なぜかデータが折り畳み?されてしまい、Sheet2は1つしかデータが移動しないという状況になってしまいました。。。

2 ● ardarim
●900ポイント ベストアンサー

サンプルマクロです。
ExtractRowsで実行します。

Const Keyword1 As String = "りんご"
Const Keyword2 As String = "ごりら"

Sub ExtractRows()

 Dim r As Long

  ' シート1の書式をコピー
 Worksheets("Sheet1").Columns("A:Z").Copy
 With Worksheets("Sheet2")
 .Columns("A:Z").Select
 .Paste
 .Cells.Clear
 End With
 
  ' キーワードに一致する行をシート2へ移動
 r = 1
 Application.ScreenUpdating = False
 Call ExtractKeyword(Keyword1, r)
 Call ExtractKeyword(Keyword2, r)
 Application.ScreenUpdating = True

End Sub

Sub ExtractKeyword(ByVal Keyword As String, ByRef DstRow As Long)

 Dim r As Long
 Dim src As Worksheet, dst As Worksheet
 
 Set src = Worksheets("Sheet1")
 Set dst = Worksheets("Sheet2")
 
 For r = 1 To src.Cells.SpecialCells(xlCellTypeLastCell).Row
 If src.Cells(r, 1).Value = Keyword Then
 src.Rows(r).Cut
 dst.Rows(DstRow).Select
 dst.Paste
 DstRow = DstRow + 1
 src.Rows(r).Delete
 r = r - 1
 End If
 Next r

 Set dst = Nothing
 Set src = Nothing

End Sub

moon-fonduさんのコメント
ありがとうございます。 ですがすみません、 実行時エラー“1004” RangeクラスのSelectメソッドが失敗しました。 というダイアログが出てきてしまい、「.Columns("A:Z").Select」のところでマクロが止まってしまいます…。

ardarimさんのコメント
Selectの際にシートがアクティブになっていないとエラーになることがあるようです。 With Worksheets("Sheet2") の次の行に .Activate を入れてみていただけますでしょうか。

moon-fonduさんのコメント
回答が遅くなりまして大変申し訳ございません。 ardarimさんありがとうございます、うまくいきました! ただ、 りんご ごりら に、完全一致するデータの行のみが、Sheet2に移動しまして。 可能でしたら“部分一致”がよいので、「りんご」「ごりら」の文字列を“含む”データのあるセルの行を、 Sheet2に移動できる方法もお教えいただけますと助かります。

ardarimさんのコメント
すみません。完全一致だと読み違えていました。 出先なので確認できませんが、 If src.Cells(r, 1).Value = Keyword Then という行を If src.Cells(r, 1).Value Like "*" & Keyword & "*" Then に置き換えてみてください。

moon-fonduさんのコメント
ありがとうございます、下記のコードで書き換えました。 しかし…「.Columns("A:Z").Select」の箇所で実行時エラー1004が出てきてしまいまして、「RangeクラスのSelectメソッドに失敗しました」と出てきてしまいます。 お手数ですが、うまくいく方法を再度ご教授いただけますと幸いです。 Const Keyword1 As String = "りんご" Const Keyword2 As String = "ごりら" Sub ExtractRows() Dim r As Long ' シート1の書式をコピー Worksheets("Sheet1").Columns("A:Z").Copy With Worksheets("Sheet2") .Columns("A:Z").Select .Paste .Cells.Clear End With ' キーワードに一致する行をシート2へ移動 r = 1 Application.ScreenUpdating = False Call ExtractKeyword(Keyword1, r) Call ExtractKeyword(Keyword2, r) Application.ScreenUpdating = True End Sub Sub ExtractKeyword(ByVal Keyword As String, ByRef DstRow As Long) Dim r As Long Dim src As Worksheet, dst As Worksheet Set src = Worksheets("Sheet1") Set dst = Worksheets("Sheet2") For r = 1 To src.Cells.SpecialCells(xlCellTypeLastCell).Row If src.Cells(r, 1).Value Like "*" & Keyword & "*" Then src.Rows(r).Cut dst.Rows(DstRow).Select dst.Paste DstRow = DstRow + 1 src.Rows(r).Delete r = r - 1 End If Next r Set dst = Nothing Set src = Nothing End Sub

ardarimさんのコメント
エラーは最初のコメントでの件と同じですので、その対策を入れればよいと思います。 上のコメントのプログラムでは抜けているようですので、 改めて両方の対策をしたものを以下に貼っておきますのでご確認ください。 Const Keyword1 As String = "りんご" Const Keyword2 As String = "ごりら" Sub ExtractRows() Dim r As Long ' シート1の書式をコピー Worksheets("Sheet1").Columns("A:Z").Copy With Worksheets("Sheet2") .Activate .Columns("A:Z").Select .Paste .Cells.Clear End With ' キーワードに一致する行をシート2へ移動 r = 1 Application.ScreenUpdating = False Call ExtractKeyword(Keyword1, r) Call ExtractKeyword(Keyword2, r) Application.ScreenUpdating = True End Sub Sub ExtractKeyword(ByVal Keyword As String, ByRef DstRow As Long) Dim r As Long Dim src As Worksheet, dst As Worksheet Set src = Worksheets("Sheet1") Set dst = Worksheets("Sheet2") For r = 1 To src.Cells.SpecialCells(xlCellTypeLastCell).Row 'If src.Cells(r, 1).Value = Keyword Then If src.Cells(r, 1).Value Like "*" & Keyword & "*" Then src.Rows(r).Cut dst.Rows(DstRow).Select dst.Paste DstRow = DstRow + 1 src.Rows(r).Delete r = r - 1 End If Next r Set dst = Nothing Set src = Nothing End Sub

moon-fonduさんのコメント
すごいです、2つのキーワードに該当するものがsheet2に移動できました!ありがとうございました(^^♪

質問者から

一旦、期限が来てしまいましたので締め切りました。
どうしても実行時エラー1004「RangeクラスのSelectメソッドに失敗しました」となり、
データが移動できなかったので、また気が向きましたら補足でご回答いただけますと幸いですm(__)m


関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ