VBA 抽出後、別シートにコピー

質問

ＯＳはＸＰ、Ｅｘｃｅｌは２００３を使用しています。
下記は、元シートから新規シートにデータ全部をコピーする様に組んでいるのですが、これを利用して、Ａ列に「３」が入力されているデータのみを抽出して新規シートにコピーするしたいです。

Dim cellgyo As Long '［元シート］で注目している行
Dim kakikomigyo As Long '［新規シート］で書き込む
Dim jigyosyocode As Variant '担当事業者コード
Dim tantocode As Integer '担当者コード
Dim tokuisakicode As Long '得意先コード
Dim tokuisakiname As String '得意先名
Dim yomicode As String '読みコード
Dim postcode As String '郵便番号
Dim add1 As String '住所１
Dim add2 As String '住所２
Dim telno As String '電話番号
Dim faxno As String 'FAX番号
kakikomigyo = 3 '［新規シート］に最初に書き始める行
For cellgyo = 2 To 63335 'Forループの始まり
Sheets("元シート").Select '［元シート］シートを選択／Cells(行,列)
’****
jigyosyocode = Cells(cellgyo, 1).Value
tantocode = Cells(cellgyo, 5).Value
tokuisakicode = Cells(cellgyo, 2).Value
tokuisakiname = Cells(cellgyo, 3).Value
yomicode = Cells(cellgyo, 4).Value
postcode = Cells(cellgyo, 16).Value
add1 = Cells(cellgyo, 17).Value
add2 = Cells(cellgyo, 18).Value
telno = Cells(cellgyo, 19).Value
faxno = Cells(cellgyo, 20).Value
If jigyosyocode = "0" Then
Exit For
End If
Sheets("新規シート").Select
Cells(kakikomigyo, 1).Value = jigyosyocode 'Cells(行,列)
Cells(kakikomigyo, 2).Value = tantocode
Cells(kakikomigyo, 3).Value = tokuisakicode
Cells(kakikomigyo, 4).Value = tokuisakiname
Cells(kakikomigyo, 5).Value = yomicode
Cells(kakikomigyo, 6).Value = postcode
Cells(kakikomigyo, 7).Value = add1
Cells(kakikomigyo, 8).Value = add2
Cells(kakikomigyo, 9).Value = telno
Cells(kakikomigyo, 10).Value = faxno
kakikomigyo = kakikomigyo + 1
Next cellgyo
-----------------------
-----------------------
データを抽出しようと思い、
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="3"
Selection.CurrentRegion.Copy
を　****のところに挿入してみたのですが、
どうも上手く行きません。

説明の足りないところあるかと思いますが、
どなたか修正点教えて下さいますようお願いします。

回答No.1

rivoisu · ベストアンサー

いったん変数に代入してから新規シートに転記している一発でやっても問題ないと思います。
63335 までのforループから途中でexit for　で抜けるというのは構造がきれいでないと思うので最終行を取得してからのfor　nextにしています。（私はこれも好きではない）
「条件で抽出」となると反射的にFindを使うと考えないほうがいいです。
この場合全件見るわけですからその中で条件に合うときに（If Cells(行1, 1) = 3 Then) 転記をすればよろしい。
With woｒksheets("新規シート")から　end　with
この間は　　. (ピリオド)　で始まる部分は頭にwotksheets("新規シート")がついているものと同じになります。
.cells(1,1)　は　woｒksheets("新規シート").cells(1,1)　と同じ意味
=の右辺のcellsは. (ピリオド)　がないのでアクティブなシートのcellということになります。　（.valueは省略可なので省略しています）

元のコードもかなり無駄があるようなので全面的に書き直しています。

Sub zz()
　　Dim 行1 As ｌong　　' 元データの行カウンター
　　Dim 行2 As ｌong ' 新規データの行カウンター
　　Dim 最終行 As Long
　　Sheets("元シート").Activate
　　最終行 = Cells(Rows.Count,1).End(xlUp).Row　’A列にデータがある最終行を取得
　　行2 = 2
　　For 行1 = 2 To 最終行
　　　　If Cells(行1, 1) = 3 Then
　　　　　　　　行2 = 行2 + 1
　　　　　　　　With wotksheets("新規シート")
　　　　　　　　　　.Cells(行2, 1) = Cells(行1, 1)
　　　　　　　　　　.Cells(行2, 2) = Cells(行1, 5)
　　　　　　　　　　.Cells(行2, 3) = Cells(行1, 2)
　　　　　　　　　　.Cells(行2, 4) = Cells(行1, 3)
　　　　　　　　　　.Cells(行2, 5) = Cells(行1, 4)
　　　　　　　　　　.Cells(行2, 6) = Cells(行1, 16)
　　　　　　　　　　.Cells(行2, 7) = Cells(行1, 17)
　　　　　　　　　　.Cells(行2, 8) = Cells(行1, 18)
　　　　　　　　　　.Cells(行2, 9) = Cells(行1, 19)
　　　　　　　　　　.Cells(行2, 10) = Cells(行1, 20)
　　　　　　　　End With
　　　　End If
　　Next

お礼

ご回答いただき、ありがとうございます。

月曜出社しましたら、抽出の仕方のところやご指摘いただきました所の修正も致しまして、
マクロを完成するように努力致します。

テキスト本の通りにしか出来ない初心者なので、無駄な所も多いです。
出来るだけ簡潔にくみたいと思っていたので、ご指摘いただき感謝しています。

最後ではありますが、お礼の書き込みが遅くなり申し訳ありませんでした。

回答No.2

Wendy02

こんばんは。

>を　****のところに挿入してみたのですが、
If Cells(cellgyo, 1).Rows.Hidden =False Then

とするのですが、ここでは、SpecialCells が使えます。
なお、この手のマクロの場合は、シートのSelect やActivate を使う必要はありません。ただ、最後に、必要なら、SinkiSh.Select をしたら良いと思います。Activate は、シートを複数選択されているときに解除できませんので、この場合は、Select のほうがよいです。

'-------------------------------------------

Sub TestMacro1()
　　'Dim i As Long '［元シート］で注目している行(使っていません）
　　Dim j As Long '［新規シート］で書き込む行
　　Dim LastRow As Long
　　Dim myRng As Range
　　Dim Rng As Range
　　Dim r As Variant

　　Dim MotoSh As Worksheet
　　Dim SinkiSh As Worksheet
　　Dim myData(0 To 9) As String 'データを入れる変数

　　Set MotoSh = Worksheets("元シート")
　　Set SinkiSh = Worksheets("新規シート")
　　j = 3 '［新規シート］に最初に書き始める行
　　'-------------------------------------------
　　With MotoSh
　　　　'オートフィルタ
　　　　LastRow = .Range("A65536").End(xlUp).Row
　　　　Set myRng = .Range("A1").Resize(LastRow, 20)
　　　　myRng.AutoFilter Field:=1, Criteria1:=3
　　End With

　　Set Rng = myRng.SpecialCells(xlCellTypeVisible)

　　Application.ScreenUpdating = False
　　For Each r In Rng.Rows
　　　　With r
　　　　　　If r.Row > 1 Then　'フィールド行は飛ばす
　　　　　　　　myData(0) = .Cells(1, 1).Value '担当事業者コード
　　　　　　　　myData(1) = .Cells(1, 5).Value '担当者コード
　　　　　　　　myData(2) = .Cells(1, 2).Value '得意先コード
　　　　　　　　myData(3) = .Cells(1, 3).Value ' 得意先名
　　　　　　　　myData(4) = .Cells(1, 4).Value '読みコード

　　　　　　　　myData(5) = .Cells(1, 16).Value '郵便番号
　　　　　　　　myData(6) = .Cells(1, 17).Value '住所１
　　　　　　　　myData(7) = .Cells(1, 18).Value '住所２
　　　　　　　　myData(8) = .Cells(1, 19).Value '電話番号
　　　　　　　　myData(9) = .Cells(1, 20).Value 'FAX番号
　　　　　　　　SinkiSh.Cells(j, 1).Resize(, 10).Value = myData()
　　　　　　　　j = j + 1
　　　　　　End If
　　　　End With
　　Next r
　　MotoSh.Range("A1").AutoFilter
　　Application.ScreenUpdating = True

　　Set myRng = Nothing
　　Set MotoSh = Nothing
　　Set SinkiSh = Nothing
End Sub

お礼

お礼の書き込みが遅くなり申し訳ありませんでした。

Wendy02さんに書いて頂いたものも、withが使われているので、
私自身、もう少しwithを使う事を頭に入れなければと勉強になりました。

今現在は「= False」や「= True」を使って組むのは全く出来ないでいるので、
月曜に実際のデータを使いながら教えて頂いた事を勉強させて頂きます。
ご回答いただき、ありがとうございました。