[[20080811184513]]　『指定したデータで抽出された部分のみをコピーさせ』（苦労人）　ページの最後に飛ぶ

『指定したデータで抽出された部分のみをコピーさせるマクロ』（苦労人）

 [A]列でオートフィルタにて抽出したあと、抽出された列の一部だけ
 コピーできるようなことがマクロでできましたら教えてください。

 Sheet1　[A]   [B]    [C]     [D] 
 [1]      A     A1    A11   A111
 [2]      A     A2    A22   A222
 [3]      B     B1    B11   B111
 [4]      B     B2    B22   B222
 [5]      C     C1    C11   C111

 例えば[A]列をAという条件でオートフィルタした時は、[A1]から[C2]
 の範囲をコピー、Cという条件でオートフィルタした時は、[A5]から[C5]
 の範囲をコピーして別のシートに貼り付けるといった操作になります。
 コピーする列の範囲（例えば[C]列まで）は変わりません。

 操作の流れとしては、
 1.[A]列をAという条件でオートフィルタ
 2.オートフィルタで表示された[1]から[2]行目のうち、[A1]から[C2]
 の範囲をコピー
 3.オートフィルタしたAという条件の名前のワークシートを作成
 4.Aという名前のワークシートに2でコピーした部分を貼り付け
 5.[A]列をBという条件でオートフィルタ
 以下同じ操作のくりかえしとなります。

 よろしくおねがいします。

 条件はどのようにして与えるのでしょう？
 あと多分ですが項目行を１行目に作らないとだめかも。

 参考まで。
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_autofilter.html
 （歩行者）

 歩行者さん、コメントありがとうございます。
 抽出条件は、理想は[A]列に入力されている情報（下記例だとA、B、C）をすべて
 自動でというのが理想ですが、難しいようでしたら、
 オートフィルタまでは手作業で行い、それ以降の作業（上記操作流れの2,3,4）を
 マクロでできないものかと考えています。

 あと、項目行は1行目に追加します。

 過去ログ
[[20070730174656]]　『VBA-データ抽出、転送方法』
 が参考になるのでは？
 （歩行者）

 Dictionaryで重複のないA列の値を取り出し、AdvancedFilterで各シートへ抽出する例です。
細かいところは無視しています。　(Hatch)
Sub test()
  Dim myDic As Object, myKey
  Dim c, myVal
  Dim i As Long, lrow As Long
  Set myDic = CreateObject("Scripting.Dictionary")
  lrow = Range("A" & Rows.Count).End(xlUp).Row
  myVal = Range("A2:A" & lrow).Value
      For Each c In myVal
          If Not c = Empty Then
              If Not myDic.Exists(c) Then
                  myDic.Add c, ""
              End If
          End If
      Next
      myKey = myDic.Keys
      For i = 0 To myDic.Count - 1
          Range("F2").Formula = "=A2=" & """" & myKey(i) & """"
          Range("A1:C" & lrow).AdvancedFilter _
                Action:=xlFilterCopy, _
                CriteriaRange:=Range("F1:F2"), _
                CopyToRange:=Worksheets(myKey(i)).Range("A1"), _
                Unique:=False
      Next i
  Set myDic = Nothing
End Sub

 コピーしたExcelファイルでテストして下さい。
 データのあるシート名は適宜変更して下さい。
 既にシートが作成されていても、強制削除します。
 Ｄ列は転記しなくていいんですよね？

 Sub Test()
     Dim Dic As Object
     Dim key As Variant
     Dim sh1 As Worksheet
     Dim sh2 As Worksheet
     Dim Csh As Worksheet
     Dim r As Range, rr As Range

  Application.ScreenUpdating = False

  Set sh1 = Worksheets("Sheet1")  ' 適宜シート名変更
  Set Dic = CreateObject("Scripting.Dictionary")

  With sh1
      For Each r In .Range(.[A2], .Cells(Rows.Count, "A").End(xlUp))
          Dic(r.Value) = Empty
      Next
  End With

  For Each key In Dic.keys
     For Each Csh In Worksheets
         If key = Csh.Name Then
            Application.DisplayAlerts = False
            Csh.Delete
            Application.DisplayAlerts = True
         End If
     Next

     Worksheets.Add After:=Worksheets(Worksheets.Count)
     ActiveSheet.Name = key
     Set sh2 = Worksheets(key)

      With sh1
           .Range("A1").AutoFilter Field:=1, Criteria1:=key
           Set rr = .Range(.[A2], .Cells(Rows.Count, 1).End(xlUp).Resize(, 3)) _
                    .SpecialCells(xlCellTypeVisible)
           rr.Copy Destination:=sh2.Range("A1")
           .AutoFilterMode = False
      End With
  Next

  Set Dic = Nothing
  Set sh1 = Nothing
  Set sh2 = Nothing
  Application.ScreenUpdating = True
 End Sub
 （歩行者）

 Hatchさん、歩行者さんありがとうございました。
 上記マクロでOKでした。

 また、質問では[A1]から[C2] の範囲をコピーとしましたが、
 抽出された行単位でコピーする必要もでてきましたが、

 Set rr = .Range(.[A2], .Cells(Rows.Count, 1).End(xlUp).Resize(, 3)) _
                    .SpecialCells(xlCellTypeVisible)
           rr.Copy Destination:=sh2.Range("A1")

 を、http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_autofilter.htmlや
 過去ログを参考に以下のように変更することでOKでした。

 .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
　Destination:=sh2.Range("A1")

 (苦労人)

  解決済みのようですが。 
[[20080808234849]]『オートフィルタで集計後にＶＢＡマクロでデータを取得したい』
  のような方法で，抽出された行のみにしてから，最後に，Ｄ列以後の列を削除する
  コードを追加すれば，結果的には，希望のデータが出来るようになります。
       コピーでなく，処理になりますので,一旦シートをどこかにコピーしてから
実行することになりますが，同じ結果と思います。（夏雲）
   最後に，Ｄ列以後の列を削除するコード：ここでは特に表記していません。

 夏雲さんへ
 Intersect メソッドを使用して必要な範囲を指定すれば、わざわざ削除する必要はないと思いますよ。
 ⇒基のデータに変更を加えず、振り分ける事を目的とするのならばですけど。
 余談でした。
 （歩行者）

 （歩行者）さん アドバイスありがとうございます。

 Intersect メソッドは普段使っていないので，適当がどうか
よくわかりませんが，範囲指定した後はどう処理するのでしょうか。
  最終的にはD列以降のデータは不要なので，いづれかに削除しなければ希望の
データ表が出来上がらないように思うのですが。
  [[20080808234849]]『オートフィルタで集計後にＶＢＡマクロでデータを取得したい』
で紹介の手法は元データから抽出した表示データ行の全体を残すという方法で
この方法を前提として利用する場合の話を紹介したものになります。（夏雲）

 夏雲さん

 > ⇒基のデータに変更を加えず、振り分ける事を目的とするのならばですけど。
 後々よく考えたらこの部分は不要だったと思います。

 >最終的にはD列以降のデータは不要なので，いづれかに削除しなければ希望の
 >データ表が出来上がらないように思うのですが。
 Ｄ列以降が不要であれば、抽出されたデータ範囲（Ａ～最後の列）からＡ～Ｃ列に絞り込んでおいて、
 その範囲を転記するかコピペすればいいのでは、と回答したつもりです。

 提示したコードではIntersect メソッドの代わりにResizeで処理してますけど。
 （歩行者）

 （歩行者)様
いろいろ方法があると思いますが，最初に書きましたように
私の提案方法は転記とか，コピーで目標の表を別のところに
作成するということでなく。
 予め，そっくり複製したシートそのものを加工して不要部を
削り落とす（削除）する手法でしたので，少しやり方が違っていました。

 上のコメントは、夏雲さんでいいのでしょうか？

 私も方法は色々あると思ってます。
 Intersect メソッド等を知る前なら、同じ方法を行なっていたと思いますし。
 ひとつの案として下さい。
 （歩行者）

コメント返信：

[ 一覧(最新更新順) ]

[[20080811184513]] 『指定したデータで抽出された部分のみをコピーさせ』（苦労人） ページの最後に飛ぶ

[[20080811184513]]　『指定したデータで抽出された部分のみをコピーさせ』（苦労人）　ページの最後に飛ぶ