前回の質問のし直しです

vbaの条件付抽出ですが、別ブックにコピペするコードです。
なんとか下記のコードを書いたのですが、これだと１件しかコピペ出来ませんでした。
勉強している途中のため、支離滅裂なコードかも知れません。

①条件に合致するデータを全てコピペ
②抽出元データは日々増えていきます
③添付画像のA・C・D・F・G列のデータのみ必要です（今のコードは全列のコピペ）
④コピー先のデータを一度クリアしてから新たにコピペをするようにしたい
⑤抽出条件はE列の「種別」で、外注ならブック名「外注」に、仕入ならブック名「仕入」、未払ならブック名「未払」に抽出してコピペしたい。※一度に無理なら外注のデータのみを抽出するコードで、他は条件を書き換えてコピーして使います。

現在は１行しかコピー出来ません。また、外注のみになっています。

With ThisWorkbook.Worksheets("sheet1")このwithの所で、for－nextで調べていき、E列の文字が（外注）のときに外注ブックへコピペ・・・とIF分で指定するのだと思いますが・・・

何分、勉強中で前回も色々な方々が書き込みして下さいましたが・・・あれこれとゴチャ混ぜになってしまったために質問し直します。

出来ましたらコードを組んで頂けないでしょうか？


Sub データ抽出()

Dim myPath As String, fn As String
Dim lastRow As Long, myLst As Long

Application.ScreenUpdating = False

Dim ws As Worksheet
myPath = "*****" & "\"　＜－－－－ここはパス名を入れます
fN = "外注.xls"

Workbooks.Open myPath & fn

Set ws = Workbooks(fn).Worksheets("sheet1")
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

If lastRow > 1 Then

Range(ws.Cells(1, "A"), ws.Cells(lastRow, "G")).ClearContents

End If

With ThisWorkbook.Worksheets("sheet1")
.Activate

myLst = .Cells(Rows.Count, "A").End(xlUp).Row

If myLst > 1 Then
Range(.Cells(2, "A"), .Cells(2, "G")).Copy　＜－－－－ここが問題かと・・・
ws.Range("A2").PasteSpecial xlPasteValues

End If

End With

With Workbooks(fn)
.Save
.Close

End With

Application.ScreenUpdating = True

End Sub


長くなりますが、コードを書くコツというか順番を教えて頂けたら助かります。
自分は今回
１．やりたいことは何か
２．どのブック・シートからデータを抽出したいのか
３．どのブックへ書き出したいのか
４．どのデータが必要なのか（コピーしたいデータはどこなのか）
という順番で考えました。
まだまだ勉強中のため、検索や教えて頂いたものの応用でしかコードは書けません。
当然ながら、教えて頂く方々の書き方や癖もあるので少し違うだけで解らなくなったりします。
自分なりのコードが書けるように上達するにはどうしていったら良いかのアドバイスも頂けると幸いです。

No.1 ベストアンサー 回答者： hallo-2007 回答日時： 2015/06/08 16:36

先の質問で回答したものです。

VBAの勉強と云う事で参考までに、コードを提示しておきますが
うまく作動しなかったとの事ですの参考程度です。
実は、この方法はあまり実用的ではありません。理由は
全ての行を2行目から最後までチェックして行きますが、当然
データが増えたら遅くなります。
そこで、別の提案をしておきます。
とりあえず、抽出結果を表示する為に別シートを準備します。
エクセルの機能でアドバンスフィルターを使います。
詳しくは
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/v …
のサイトででも勉強してみてください。
一例です。A・C・D・F・G列のデータのみ必要なので
抽出結果を表示するシート
　　A　　　B　　C　　　D　　　　E　　　　F
１　種別　日付　得意先　適用　　請求金額　支払金額
２　外注
３　
とSheet1の一行目の項目を張り付けて準備します。
（一行目が良く見えないので上は適当です）
A1~A2　が抽出する条件を記載しています（種別が　外注　を抽出）
B～Fに　抽出する項目の名前になります。
このシートをアクティブにした状態で

Sub データ抽出()
Sheets("Sheet1").Columns("A:G").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:A2"), CopyToRange:=Range("B1:F1"), Unique:=False
End Sub
を事項してみて下さい。E列が外注の行が抽出されます。
後は、A2セルを　仕入、未払　にすれば、それに対応した抽出が出来ます。
ここまで出来たら、後に
Columns("B:F").Copy
Workbooks.Open "*****" & "\" & Range("A2").Value & ".xls"
Sheets("Sheet1").Select
Columns("A:E").Select
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True

と続ければご希望の動作になりませんでしょうか。
コードもシンプルになり、動作も軽いはずですし、A2セルを変更するだけで
他の対応も出来ます。


以下、参考コード
Sub データ抽出()
Dim myPath As String, fn As String
Dim lastRow As Long, myLst As Long
Dim ws As Worksheet
myPath = "*****" & "\"　＜－－－－ここはパス名を入れます
fN = "外注.xls"
Workbooks.Open myPath & fn
Set ws = Workbooks(fn).Worksheets("sheet1")
’↓④コピー先のデータを一度クリアしてから新たにコピペをするようにしたい
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ｗs.Range("A2:G" & lastRow).ClearContents

'↓外注のデータのみを抽出するコードで、
With ThisWorkbook.Worksheets("sheet1")
myLst = .Cells(Rows.Count, "A").End(xlUp).Row
for i=2 to myLst
If range("E" & i).Value="外注" Then
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row+1
ws.Range("A" & lastRow).Value=.Range("A" & i).Value
ws.Range("B" & lastRow).Value=.Range("C" & i).Value
ws.Range("C" & lastRow).Value=.Range("D" & i).Value
ws.Range("D" & lastRow).Value=.Range("F" & i).Value
ws.Range("E" & lastRow).Value=.Range("G" & i).Value
End If
Next
End With
'↓上書きして保存
Workbooks(fn).Close SaveChanges:=True
End Sub

この回答へのお礼

何度も有難うございました。やっと思い通りのものになりました。
動作も速くスッキリしました。
業者が多く、外注や仕入を一つのブックで管理しきれないのでてこずりました。
本当に有難うございます。
vba、難しいですね（笑）

お礼日時：2015/06/08 16:59