Excelに関する質問です。特定のキーワードを含む行全てを1つずつ、別シートに移動させるマクロはないでしょうか。


Sheet1のF列に、ずらりとデータが10000行近く並んでおります。
この中から、「りんご」という文字列を含む(前文一致・後文一致・部分一致)セルがあった場合、そのセルのある“行”を全て“切り取り”し、Sheet2のシートに移すことは出来ないでしょうか。

“切り取り”ではなく“コピー”でも問題ないのですが、Sheet1からは「りんご」文字列を含むデータを後に削除したいです。

よろしくお願い致します。

回答の条件
  • 1人5回まで
  • 登録:2015/06/13 20:17:42
  • 終了:2015/06/18 00:39:16

ベストアンサー

id:taknt No.3

きゃづみぃ回答回数13537ベストアンサー獲得回数11982015/06/14 09:40:37

ポイント300pt
Sub main()
Dim a As Long
Dim b As Long
Dim c As Long

移動元シート = "Sheet1"
移動先シート = "Sheet2"

b = Worksheets(移動元シート).Cells(Rows().Count, "F").End(xlUp).Row
c = Worksheets(移動先シート).Cells(Rows().Count, "F").End(xlUp).Row
If c = 1 And Worksheets(移動先シート).Cells(1, "F") = "" Then
Else
    c = c + 1
End If
    

For a = b To 1 Step -1
    If InStr(Worksheets(移動元シート).Cells(a, "F"), "りんご") > 0 Then
        
        Worksheets(移動元シート).Rows(a).Cut
        Worksheets(移動先シート).Rows(c).Insert Shift:=xlDown
        Worksheets(移動元シート).Rows(a).Delete Shift:=xlUp
        c = c + 1
    End If
Next a

End Sub

id:moon-fondu

うまくデータを別シートに移動できました!ありがとうございます。

2015/06/18 00:38:22

その他の回答(2件)

id:SuperDbTool No.1

やじるし回答回数4ベストアンサー獲得回数02015/06/14 00:27:34

id:moon-fondu

ありがとうございます。動画を拝見しました。表作ったり、少し大変そうですね。。。

2015/06/18 00:36:58
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912015/06/14 01:44:40

ポイント50pt

1行目はタイトル行の前提です。

Sub MoveData()
    Const KeyWord = "りんご"
    
    Dim srcWS As Worksheet
    Set srcWS = Worksheets("Sheet1")
    
    Dim dstWS As Worksheet
    Set dstWS = Worksheets("Sheet2")
    dstWS.Cells.Clear
    
    If srcWS.AutoFilterMode Then srcWS.AutoFilterMode = False
    srcWS.UsedRange.AutoFilter Field:=6, Criteria1:="=*" & KeyWord & "*"
    srcWS.Range("A1").CurrentRegion.EntireRow.Copy dstWS.Range("A1")
    
    srcWS.Range("A1").CurrentRegion.EntireRow.Delete
    
    srcWS.AutoFilterMode = False
    srcWS.Rows(1).Insert
    dstWS.Rows(1).Copy srcWS.Rows(1)
End Sub
id:moon-fondu

ありがとうございます!マクロは実行できたのですが…なぜかデータを移動させたり、うまくいきませんでした。タイトル行の後に空白の行とかいろいろあったからでしょうか・・・。

2015/06/18 00:37:52
id:taknt No.3

きゃづみぃ回答回数13537ベストアンサー獲得回数11982015/06/14 09:40:37ここでベストアンサー

ポイント300pt
Sub main()
Dim a As Long
Dim b As Long
Dim c As Long

移動元シート = "Sheet1"
移動先シート = "Sheet2"

b = Worksheets(移動元シート).Cells(Rows().Count, "F").End(xlUp).Row
c = Worksheets(移動先シート).Cells(Rows().Count, "F").End(xlUp).Row
If c = 1 And Worksheets(移動先シート).Cells(1, "F") = "" Then
Else
    c = c + 1
End If
    

For a = b To 1 Step -1
    If InStr(Worksheets(移動元シート).Cells(a, "F"), "りんご") > 0 Then
        
        Worksheets(移動元シート).Rows(a).Cut
        Worksheets(移動先シート).Rows(c).Insert Shift:=xlDown
        Worksheets(移動元シート).Rows(a).Delete Shift:=xlUp
        c = c + 1
    End If
Next a

End Sub

id:moon-fondu

うまくデータを別シートに移動できました!ありがとうございます。

2015/06/18 00:38:22

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

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

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

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

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