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

Question

moon-fondu

236

235もっと見る

1000pt

インターネット学習・教育

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

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

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

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

回答の条件

1人10回まで

登録：2017/11/11 22:54:15
終了：2017/11/30 21:26:36

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

No.1

hathi216492017/11/12 19:25:07

100pt

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

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

他5件のコメントを見る

ご回答ありがとうございます。
うーん、

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行目でオブジェクトの定義エラーになってしまいました。

2017/11/17 23:53:35

例えば次のように直して実行してみてください。
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

2017/11/18 16:18:16

ご回答ありがとうございます！返信が遅くなりまして、大変申し訳ございません<m(__)m>
すみません、Aが抜けておりました・・・。
hathiさんのマクロを参考に修正・実行してみたのですが、

Stop ' wawaは適当　A15は適当(データのある行）

の箇所で、マクロが[中断]してしまうのです。
中断せずに、目的のデータをsheet1からsheet2に移動できたらいいのですが…。

2017/11/22 23:51:16

前に補足で書いたように、
｢　なお、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行目になります。

2017/11/23 08:00:02

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

2017/11/28 08:07:58

済みませんでした。
下のではどうでしょうか。

Sub SampleXY()
With Sheets("Sheet1").Range("A1")
.AutoFilter Field:=1, Criteria1:="リンゴ"
.CurrentRegion.Copy Sheets("Sheet2").Range("A2")
End With
End Sub

2017/11/29 00:00:05

うーん、なぜかデータが折り畳み？されてしまい、Sheet2は1つしかデータが移動しないという状況になってしまいました。。。

2017/11/30 21:21:33

質問者から

moon-fondu2017/12/06 02:40:48

一旦、期限が来てしまいましたので締め切りました。

どうしても実行時エラー1004「RangeクラスのSelectメソッドに失敗しました」となり、

データが移動できなかったので、また気が向きましたら補足でご回答いただけますと幸いですm(__)m

規約違反として通知

コメントはまだありません

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

リクエスト送信済

回答リクエストを送信したユーザーはいません

ardarim · Accepted Answer · 2017-11-17T01:36:04+09:00

No.2

ardarim8971452017/11/17 01:36:04

900pt

サンプルマクロです。
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

他5件のコメントを見る

ありがとうございます。
ですがすみません、

実行時エラー“1004”
RangeクラスのSelectメソッドが失敗しました。

というダイアログが出てきてしまい、「.Columns("A:Z").Select」のところでマクロが止まってしまいます…。

2017/11/17 23:56:16

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

2017/11/18 14:34:01

回答が遅くなりまして大変申し訳ございません。
ardarimさんありがとうございます、うまくいきました！
ただ、

りんご
ごりら

に、完全一致するデータの行のみが、Sheet2に移動しまして。

可能でしたら“部分一致”がよいので、「りんご」「ごりら」の文字列を“含む”データのあるセルの行を、
Sheet2に移動できる方法もお教えいただけますと助かります。

2017/11/22 23:57:15

すみません。完全一致だと読み違えていました。

出先なので確認できませんが、
If src.Cells(r, 1).Value = Keyword Then
という行を
If src.Cells(r, 1).Value Like "*" & Keyword & "*" Then
に置き換えてみてください。

2017/11/23 10:14:20

ありがとうございます、下記のコードで書き換えました。
しかし…「.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

2017/11/28 08:06:41

エラーは最初のコメントでの件と同じですので、その対策を入れればよいと思います。

上のコメントのプログラムでは抜けているようですので、
改めて両方の対策をしたものを以下に貼っておきますのでご確認ください。

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

2017/12/02 15:28:18

すごいです、2つのキーワードに該当するものがsheet2に移動できました！ありがとうございました(^^♪

2017/12/24 15:18:33

ardarim · Accepted Answer · 2017-11-17T01:36:04+09:00

No.2

ardarim8971452017/11/17 01:36:04ここでベストアンサー

900pt

サンプルマクロです。
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

他5件のコメントを見る

ありがとうございます。
ですがすみません、

実行時エラー“1004”
RangeクラスのSelectメソッドが失敗しました。

というダイアログが出てきてしまい、「.Columns("A:Z").Select」のところでマクロが止まってしまいます…。

2017/11/17 23:56:16

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

2017/11/18 14:34:01

回答が遅くなりまして大変申し訳ございません。
ardarimさんありがとうございます、うまくいきました！
ただ、

りんご
ごりら

に、完全一致するデータの行のみが、Sheet2に移動しまして。

可能でしたら“部分一致”がよいので、「りんご」「ごりら」の文字列を“含む”データのあるセルの行を、
Sheet2に移動できる方法もお教えいただけますと助かります。

2017/11/22 23:57:15

すみません。完全一致だと読み違えていました。

出先なので確認できませんが、
If src.Cells(r, 1).Value = Keyword Then
という行を
If src.Cells(r, 1).Value Like "*" & Keyword & "*" Then
に置き換えてみてください。

2017/11/23 10:14:20

ありがとうございます、下記のコードで書き換えました。
しかし…「.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

2017/11/28 08:06:41

エラーは最初のコメントでの件と同じですので、その対策を入れればよいと思います。

上のコメントのプログラムでは抜けているようですので、
改めて両方の対策をしたものを以下に貼っておきますのでご確認ください。

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

2017/12/02 15:28:18

すごいです、2つのキーワードに該当するものがsheet2に移動できました！ありがとうございました(^^♪

2017/12/24 15:18:33

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

ベストアンサー

ardarim8971452017/11/17 01:36:04

その他の回答（1件）

hathi216492017/11/12 19:25:07

ardarim8971452017/11/17 01:36:04ここでベストアンサー

質問者から

コメント（0件)

この質問への反応（ブックマークコメント）