Excel2003 検索後コピー貼付マクロ

質問

データ一覧から、必要な項目のデータを別sheetへコピーペーストできるマクロを教えてください。

下記の一覧が "sheetA" にあります。

***sheetA***
【A列】 　　　　【B列】 　　【C列】
圧入ピン 　　A01 　　　　　部品欠品
圧入ピン 　　C03 　　　　　向き違い
圧縮　　 　　A01 　　　　　部品欠品
圧縮 　　C03 　　　　　向き違い
圧縮 　　C22 　　　　　不完全
圧縮 　　C03 　　　　　向き違い
案内板 　　A01 　　　　　部品欠品
案内板 　　C04 　　　　　爪外れ

ここから"A列が圧縮"のデータのみを、"sheetB"へコピーペーストするマクロを教えてください。

***sheetB***
【A列】 　　　　【B列】　　　 　　【C列】
圧縮　　　　　A01 　　　　　部品欠品
圧縮 　　C03 　　　　　向き違い
圧縮 　　C22 　　　　　不完全
圧縮 　　C03 　　　　　向き違い

以上、よろしくお願い致します。

回答No.4

kigoshi · ベストアンサー

Sub bPaste()
Const targetStr As String = "圧縮"
Dim rIdx1, rIdxA, targetN As Long
Sheets("SheetA").Select
Columns("A:A").Insert Shift:=xlToRight
For rIdx1 = 1 To Range("B65536").End(xlUp).Row
Cells(rIdx1, 1).Value = rIdx1
Next
Cells(1, 2).Select
Selection.SortSpecial SortMethod:=xlSyllabary, Key1:=Range("B1"), Order1:=xlAscending, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For rIdx1 = 1 To Range("A65536").End(xlUp).Row
If Cells(rIdx1, 2).Value = targetStr Then
rIdxA = rIdx1
Exit For
End If
Next
For rIdx1 = rIdxA To Range("A65536").End(xlUp).Row
If Cells(rIdx1, 2).Value = targetStr Then
targetN = targetN + 1
Else
Exit For
End If
Next
Range(Cells(rIdxA, 2), Cells(rIdxA + targetN - 1, 4)).Copy
Sheets("SheetB").Activate
Range(Cells(1, 1), Cells(targetN, 3)).PasteSpecial xlPasteAll
Cells(1, 1).Select
Sheets("SheetA").Select
Cells(1, 1).Select
Selection.SortSpecial SortMethod:=xlSyllabary, Key1:=Range("A1"), Order1:=xlAscending, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns("A:A").Delete Shift:=xlToLeft
End Sub

何をやっているのかは、ご自身で解析してみてください。

お礼

解析できました。

本当にありがとうございました。
勉強になりました。

***下記のようにしました。***

Sub bPaste()

MyCode = Application.InputBox("作業内容入力", Type:=2)
Dim targetStr As String
targetStr = MyCode
'targetStr = InputBox("入力してね")

Dim rIdx1, rIdxA, targetN As Long

Sheets("SheetA").Select
Columns("A:A").Insert Shift:=xlToRight

For rIdx1 = 1 To Range("B65536").End(xlUp).Row
Cells(rIdx1, 1).Value = rIdx1
Next

Cells(1, 2).Select
Selection.SortSpecial SortMethod:=xlSyllabary, Key1:=Range("B1"), Order1:=xlAscending, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

For rIdx1 = 1 To Range("A65536").End(xlUp).Row
If Cells(rIdx1, 2).Value = targetStr Then
rIdxA = rIdx1
Exit For
End If
Next
For rIdx1 = rIdxA To Range("A65536").End(xlUp).Row
If Cells(rIdx1, 2).Value = targetStr Then
targetN = targetN + 1
Else
Exit For
End If
Next

Range(Cells(rIdxA, 2), Cells(rIdxA + targetN - 1, 4)).Copy
Sheets("SheetB").Activate
Range(Cells(1, 1), Cells(targetN, 3)).PasteSpecial xlPasteAll
Cells(1, 1).Select

Sheets("SheetA").Select
Cells(1, 1).Select
'Selection.SortSpecial SortMethod:=xlSyllabary, Key1:=Range("A1"), Order1:=xlAscending, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns("A:A").Delete Shift:=xlToLeft
End Sub

補足

処理時間が早い為、これはいいと思うのですが
・・・・解析わかりませんでした。

"圧縮"だけでは無くて他のデータも検索、コピーペーストしたいので、

以前に使用した
MyCode = Application.InputBox("作業内容入力", Type:=2)

を使おうと思いましたが駄目でした。。。

勉強不足ですね。もう少し考えてみます。

回答No.3

imogasi

この質問は、質問と言うより、丸投げでコード作成「依頼」ではないか。
先日も入試問題の回答作成を質問コーナーにした問題がキッカケで、考える人が少なくなっていることに批判が多い。
フィルタでA列の｛圧縮」行を抜き出し、可視セルを選択して（編集ージャンプーセル選択ー可視セルーコピー）、別シートへ-貼り付ける操作をして、マクロの記録を採って勉強すること。
それをしてから判らない点があれば質問するのが筋。

補足

大変に失礼を致しました。

マクロにフィルターは、一番最初に試してみました。

マクロをそのままをコピーペーストしてしまいます。
動いているのですが、データが大きいので保存や集計に時間がかかります。
他にもマクロを使用しているし、関数も使用しているので、ここが問題なのかは調査中ですが、方法が無いかと思い相談をしてみました。

言葉足らずで大変に失礼を致しました。

*********************************************

Sub MyFilter()

'フィルター検索と貼付
Sheets("表示データベース").Select
Dim MyCode As String
Dim Rng As Range

Set Rng = Range("A1").CurrentRegion 'アクティブセル領域取得
Rng.AutoFilter 'フィルタ設定

MyCode = Application.InputBox("作業内容入力", Type:=2)
Rng.AutoFilter Field:=1, Criteria1:=MyCode '変数MyCodeに格納されたデータ抽出

'可視セルをコピー
Rng.SpecialCells(xlCellTypeVisible).Copy _
'Destination:=Sheets("試行").Range("A10")
Worksheets("KYF分析シート").Select
ActiveSheet.Paste

Rng.AutoFilter 'フィルタ解除

'「試行」シートで

With Worksheets("KYF分析シート")

End With

End Sub

***************************************

回答No.2

kigoshi

できたのであれば、質問を締め切られた方がよろしいと思います。

補足

ありがとうございます。

できたのですが
１０１４行のデータから抽出をするのに使いたい為
教えて頂いたマクロでは検索に時間がかかり過ぎていました。

他にも方法があるのではと思い閉め切りませんでした。

申し訳ありませんが、もう少し待ってから閉め切ります。

回答No.1

kigoshi

Sub aPaste()
Const targetStr As String = "圧縮"
Dim rIdx1, rIdx2 As Long
For rIdx1 = 1 To Range("A65536").End(xlUp).Row
Sheets("SheetA").Select
If Sheets("SheetA").Cells(rIdx1, 1).Value = targetStr Then
rIdx2 = rIdx2 + 1
Sheets("SheetA").Activate
Range(Cells(rIdx1, 1), Cells(rIdx1, 3)).Copy
Sheets("SheetB").Activate
Range(Cells(rIdx2, 1), Cells(rIdx2, 3)).PasteSpecial xlPasteAll
End If
Next
End Sub

お礼

大変に失礼を致しました。

できました。ありがとうございました。

補足

ありがとうございました。

素人で申し訳ありませんが、"圧縮"は４行のデータがあります。
１行だけコピーされました。４行コピーをしたいです。

また、行数は項目によってバラバラです。

以上、よろしくお願い致します。