文字列を検索しその列をコピーする(VBA)

よろしくお願いします。

OS：WINDOWS 2000 PRO
環境：OFFICE 2003

エクセルのVBAについての質問です。

A列には数値コードが入っています。
そのコードは"1"と"2"に分類されてます。
マスターはSHEET1で、このマスターから
コード1はSHEET2に、
コード2はSHEET3に
振り分けたいのですが、どうもうまくいきません・・・
A列にはコード"1" "2"以外に空白セルが存在します。
空白セルは無視したい。。。
それとこのデータはDBから抽出するのですが、
抽出したデータは規則性はありません。
抽出するごとに"1"と"2"と"空白"はランダムなので、
LOOP等のマクロを調べてやってみたのですが、出来なくて週末になってしまいました。

A列からコード1とコード2を検索して、
ヒットしたコードの行ごと各SHEETにコピーして、
なおかつ各シートA列の入力されていない一番下の
セルにコピーしたいのですが、検索でヒットした
上から順番に。。。

これをLOOPと組合わせれば、各シートにコピーするのは
問題ないような気がします。。。

Sub AAA_BBB()
.Copy Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0)
End With
End Sub

LOOP等で上記の条件を満たせる方法はないでしょうか。

ご教示を、よろしくお願いします。

No.1 ベストアンサー 回答者： masa_019 回答日時： 2005/12/10 21:04

こんにちは。

For -Eachを使ってやってみました。
各シートの1行目はタイトル行になっているものとします。

Sub test()
Dim rng As Range
With Sheets("SHEET1")
For Each rng In _
Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, 1))
If rng.Text = "コード1" Then
rng.EntireRow.Copy _
Sheets("SHEET2").Range("A65536").End(xlUp).Offset(1)
ElseIf rng.Text = "コード2" Then
rng.EntireRow.Copy _
Sheets("SHEET3").Range("A65536").End(xlUp).Offset(1)
End If
Next
End With
End Sub

この回答へのお礼

初心者相手にご回答いただき感謝に耐えません。
もちろん、解決いたしました！
ありがとうございます。

お礼日時：2005/12/11 09:19

No.2 回答者： Wendy02 回答日時： 2005/12/10 23:21

こんばんは。

タイトル行は、Sheet1, Sheet2, Sheet3 にあるという前提にしないと、このコードはうまく行きません。最初のマスターのシートは、オートフィルタを使って抽出しています。これで参考にしてみてください。なお、コードは、myCodeのところを増やし、myShtsの中も、同じ数だけシートも増やせば、さらに増えても、ループは可能です。

'-----------------------------------------
Sub Sort_OtherSheetPaste()
　 Dim myShts() As Variant
　 Dim myCode() As Variant
　 Dim i As Integer
　
　 myCode = Array("1", "2") 'コード
　 myShts = Array("Sheet2", "Sheet3") 'ペーストされるシート
　 Application.ScreenUpdating = False
　 'マスターのシート
　 With Worksheets("Sheet1").Range("A1").CurrentRegion
　
　　　For i = LBound(myCode()) To UBound(myCode())
　　　　 .CurrentRegion.AutoFilter Field:=1, Criteria1:=myCode(i)
　　　　 .Offset(1).Resize(.Rows.Count - 1).Copy Worksheets(myShts(i)).Range("A65536").End(xlUp).Offset(1)
　　　Next i
　　　.AutoFilter
　 End With
　
　 Application.ScreenUpdating = True
End Sub


なお、マクロの実行のダブりの検査は、現在のコードではなされていません。

この回答へのお礼

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

お礼日時：2005/12/11 09:20