[[20050410182653]]　『VBA：オートフィルタデータの上から7番目まで』（KUHIKUHI）　ページの最後に飛ぶ

『VBA：オートフィルタデータの上から7番目まで』（KUHIKUHI）

[マクロでオートフィルタのかかったデータの上から７番目まで]

オートフィルターをかけた状態で、２０行あるとします。
その一番上のセル（B2）から下に７番目までのセルを別のシートにコピーしたいのですが、

 Range("b2:b7").Copy
と、指定したらだめでした。
よく考えたら当たり前なのですが、フィルタをかけてあるデータの上から７番目を指定してコピーする方法をお教えいただけないでしょうか？
マクロを使用していますので、マクロの記述方法をお教えいただきたいのですが。

OS:WinXP OFFICE:Excel2003

 フィルタ後に、ctrl + shift + * で連続セル範囲を選択し、
 編集＞ジャンプ＞可視セル
 して、コピー＆貼り付けした後、不要行を削除しては？

 ちょっと難しいですが、offset や resize を使えば、
 希望の行だけコピーすることも可能でしょう。
  (INA)

INA様ご返答ありがとうございます。

実は、オートフィルターをかけた後のデータを７行ごとに別シートの別の列にコピーしたいのです。

具体的にいうと、

 　Ａ　Ｂ
 １あ　４
 ２い　６
 ３う　４
 ４え　１
 ５お　４
 ６か　１
 ７き　４
 ８く　４
 ９け　４
 10こ　６
 11さ　４
 12し　４

のようなデータが１００行ほどあり、それを、Ｂ列のデータ（日付）でフィルターをかけて、４日に対応するＡ列のデータを別シートに７データごとに別々の列にコピーしたいのです。

別シート

 　Ａ　Ｂ　Ｃ　Ｄ
 １あ　×　し　×
 ２う　×　　　　
 ３お　×
 ４き　×
 ５く　×
 ６け　×
 ７さ　×　　　　　　　　　※　“×”は手入力するセル

１～７人のデータはＡ列へ、７～１４人のデータはＣ列にコピーしたいので、オートフィルターをかけた状態で抽出したい列のデータを７データごとに取得したいのですが、一度、別の作業シートにすべてのデータを取り出して７行ごとにコピーする方法ならできたのですが、できれば作業シートにコピーすることなく実行できればと、、、

offset resize ちょっと勉強してみます。
ありがとうございました。
(KUHIKUHI)

 おはようございます。
ぱっとしませんが、ふたつ考えてみました。
よかったら参考にしてください。
Option Explicit
Sub てすと()
Dim MyA As Variant, MyAry() As Variant
Dim i As Long, j As Long, k As Long, n As Long, x As Long
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 2).Value
End With
k = 2
ReDim MyAry(1 To 7, 1 To k)
For i = 1 To UBound(MyA, 1)
    If MyA(i, 2) = 4 Then
        j = j + 1
        MyAry(j, x + 1) = MyA(i, 1)
        If j = 7 Then
            k = k + 2: j = 0: x = x + 2
            ReDim Preserve MyAry(1 To 7, 1 To k)
        End If
    End If
Next
With Sheets("Sheet2")
    .Cells.ClearContents
    If k < 257 Then
        With .Range("A1").Resize(7, UBound(MyAry, 2))
            .Value = MyAry
            .EntireColumn.AutoFit
        End With
    Else
        MsgBox "処理能力を超えました。"
    End If
End With
Erase MyA, MyAry
End Sub
Sub てすとに()
Dim SR As Range, C As Range, MyTbl As Range
Dim MyCri As String
Dim i As Long, k As Long
Dim MyFlag As Boolean
MyCri = 4
Application.ScreenUpdating = False
With Sheets("Sheet1")
    .AutoFilterMode = False
    .Range("A1").AutoFilter Field:=2, Criteria1:=MyCri
    Set MyTbl = .AutoFilter.Range.Columns(1).SpecialCells(12)
    Sheets("Sheet2").Cells.ClearContents
    If MyTbl.Cells.Count > 1 Then
        k = 1
        For Each C In MyTbl
            If C.Offset(, 1).Value = MyCri Then
                If MyFlag = False Then Set SR = C: MyFlag = True
                i = i + 1
                If i Mod 7 = 0 Then
                    .Range(SR.Address, .Range(C.Address)).Copy _
                            Destination:=Sheets("Sheet2").Cells(1, k)
                    k = k + 2: MyFlag = False
                    If k > 256 Then GoTo MyLine
                End If
            End If
        Next
        If i Mod 7 <> 0 Then
            .Range(SR.Address, .Range(SR.Address).End(xlDown)).Copy _
                                Destination:=Sheets("Sheet2").Cells(1, k)
        End If
    End If
End With
MyLine:
Sheets("Sheet1").AutoFilterMode = False
Application.ScreenUpdating = True
If k > 256 Then MsgBox "処理能力を超えました。"
Set MyTbl = Nothing
Set SR = Nothing
End Sub
（SoulMan）

Soul Man さんおはようございます！

うわぁ。
ほんとうにありがとうございます。
これから出社なので、まだ実行していませんが、会社でやってみます。
もちろん必ず報告させていただきますので、これからもよろしくお願いいたします。

 実は（エクセルの学校）は毎日訪問していていろいろ勉強させていただいております。
 こちらはレスも速攻で帰っててくるのでいつも楽しく拝見しています。これからもがんばってください。(KUHIKUHI)

 >できれば作業シートにコピーすることなく実行できればと、、、
 私はよく使いますけど、こだわる理由は何でしょうか？
 新規ブックを作業シートとして利用して、
 使用後は保存せずに破棄すれば、とくに支障はないと思いますけど･･･
  (INA)

コメント返信：

[ 一覧(最新更新順) ]

[[20050410182653]] 『VBA：オートフィルタデータの上から7番目まで』（KUHIKUHI） ページの最後に飛ぶ

[[20050410182653]]　『VBA：オートフィルタデータの上から7番目まで』（KUHIKUHI）　ページの最後に飛ぶ