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

ベストアンサー

id:ardarim No.2

ardarim回答回数897ベストアンサー獲得回数1452017/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件のコメントを見る
id: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

2017/12/02 15:28:18
id:moon-fondu

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

2017/12/24 15:18:33

その他の回答(1件)

id:hathi No.1

hathi回答回数213ベストアンサー獲得回数482017/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件のコメントを見る
id:hathi

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

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
id:moon-fondu

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

2017/11/30 21:21:33
id:ardarim No.2

ardarim回答回数897ベストアンサー獲得回数1452017/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件のコメントを見る
id: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

2017/12/02 15:28:18
id:moon-fondu

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

2017/12/24 15:18:33
id:moon-fondu

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

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

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません