[[20080330111413]]　『3行おきに30行ずつの転記』（aki）　ページの最後に飛ぶ

『3行おきに30行ずつの転記』（aki）Windows2000,Excel2000

 VBAの初心者です。よろしくお願いします。
 sheet1にオートフィルターで抽出した(A2:L300)ぐらいのリストがあるのですが、
 (抽出データなので行の数は30から300ぐらいで決まっていません)

 このリストをsheet2のA4から30行ずつ３行おきに転記していきたいのです。
 30行転記したら3行あけて4行目からまた30行ぶんという感じです。

 よろしくお願いします。

 >VBAの初心者です。

 マクロの記録等である程度はプロシージャー作った？
 オートフィルターかけるくらいはできてる？

 >30行転記したら3行あけて4行目からまた30行ぶんという感じです。

 このあたりがわからないのかな？

 できてる分のプロシージャー載せた方が良いよ。

 フィルターで抽出したデータってことだと、どうフィルターかけてるかとかわからないから。

wing000

wing000さん、早速ご返答いただいてありがとうございます。プロシージャは会社のPCなので記述できません。

おっしゃるとおり、「30行転記したら3行あけて4行目からまた30行ぶん」がわかりません。よろしくお願いします。

(aki)

 オートフィルタの抽出条件がわかれば助かるのですが、、、
 わからないので、抽出後からって事で考えましたｂ
　
 Sheet1 のデータを、Sheet2 に書き出しますが、Sheet2 を消しちゃってますので、もともと Sheet2 にデータがある場合消えてしまいます。。。
　
 ・抽出条件が固定であれば、条件を教えてください。
 ・Sheet2に、データがある場合は、どのようなデータがあるかも教えてください
　
 とりあえずUP
　
Sub test()
Dim MyA As Variant, x() As Variant
Dim i As Long
Dim n As Integer, c As Integer, j As Integer
    With Worksheets("Sheet1")
        .Range("A1").CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A1")
    End With
    With Worksheets("Sheet2")
        MyA = .Range("A1", .Range("B" & .Rows.Count).End(xlUp))
        .Cells.ClearContents
        j = WorksheetFunction.Ceiling(UBound(MyA, 1), 30)
        ReDim x(1 To j + Int(j / 30) * 4, 1 To UBound(MyA, 2))
        c = 0
        For i = 2 To UBound(MyA, 1)
            If c > 0 Then
                If (i - 2) Mod 30 = 0 Then c = c + 4
            End If
            c = c + 1
            For n = 1 To UBound(MyA, 2)
                x(c, n) = MyA(i, n)
            Next n
        Next i
        .Cells.ClearContents
        .Range("A4").Resize(UBound(x, 1), UBound(x, 2)) = x
    End With
    Erase MyA, x
End Sub
　
 ※元に戻せませんので、他Bookで検証してからお使いください。
 (キリキ）（〃⌒o⌒)b

キリキさんありがとうございます。足りない情報ばかりのなか回答していただきまして

恐縮です。実は、sheet1は抽出データを別のシートからコピペしてきたものでここが作

業シートになっています。ここで最終的なチェックを行ってsheet2の方に3行おきに30行

づつ転記していきたいのです。sheet2はいわゆる決められた書式が貼り付けられた印刷

様式となっており、この書式が3行おきに30行収まるように下方に張り付いているのです

。ですからsheet2のデータをすべて削除するのは困ります。決まった様式どおりに印刷

できれば良いので、3行あけて30行転記したら印刷、データを消して次の30行を転記して

印刷、の繰り返しでsheet1の抽出でーたがすべて印刷できればいいのですが、そんなコ

ート゛は余計わからないですし、すいませんもう少々ご教授して下さい。(aki)

 >3行あけて30行転記したら印刷、データを消して次の30行を転記して
  印刷、の繰り返しでsheet1の抽出でーたがすべて印刷できればいい

 作業シートとして"temp"シート使用
 ※上記作業シートは、自動で作成され、自動で削除されます。
 ※キリキさんの仰るとおり、フィルター実行はすでにされていると仮定したコードです。

 (aki)さん指定通り、
 A列～L列を30行ごとにSHEET2のA4セル以降に貼り付け
 印刷実行後、同じセル範囲にまた30行ずつ繰り返しています

 '-------
Sub Macro1()
Dim i As integer
Dim MyR As Long
    Sheets.Add
    ActiveSheet.Name = "temp"
    Sheets("Sheet2").Activate
    With Sheets("Sheet1")
        .Range("A1").CurrentRegion.Copy Destination:=Sheets("temp").Range("A1")
    End With
    With Sheets("temp")
        MyR = .Cells(Rows.Count, 1).End(xlUp).Row
    End With
    If MyR < 30 Then MyR = 30
    For i = 1 To Int(MyR / 30)
        With Sheets("temp")
            .Range("A" & (i - 1) * 30 + 2 & ":L" & i * 30 + 1).Copy Destination:=Sheets("Sheet2").Range("A4")
        End With
    If MsgBox("印刷しますか？：　" & i & "枚目", vbOKCancel + vbInformation, "印刷確認") = vbOK Then
        Sheets("Sheet2").PrintOut
    Else
        Application.DisplayAlerts = False
        Sheets("temp").Delete
        Application.DisplayAlerts = True
        Exit Sub
    End If
    Next i
    Application.DisplayAlerts = False
    Sheets("temp").Delete
    Application.DisplayAlerts = True
End Sub

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

wing000 (18:19コード修正)

 おっと、
 やっと手が空いて来てみたらｗ
　
 やっぱり、ダメですよね・・・
 akiさん、ごめんなさいね＾＾；
　
 wing000さん、いつもフォローありがとうございます＾＾
　
 （キリキ）（〃⌒o⌒)b

 To キリキさん
 とんでもないです。ファーストコーディングがもっとも大変で実力が出ます。
 そうなれるようがんばります。
 キリキさんのコーディングはいつ見てもすっきりさわやかです
 そういうコーディングができるようになりたい。(^^;)

wing000

キリキさん、wing000さん、ありがとうございます。

キリキさんのコードを別のbookで確認したところ何もおこりませんでした。

wing000さんのコードですと60行の抽出データでは2枚のプリントアウトがありました

が、70行だと残り10行のデータがプリントアウトされません。すいません、質問の冒頭

 >sheet1にオートフィルターで抽出した(A2:L300)ぐらいのリストがあるのですが、
 (抽出データなので行の数は30から300ぐらいで決まっていません)

と書いてしまいました。抽出データは30の倍数ではありません。31のときもあれば、50

のときもあり最高は300程度なのです。たとえ1行でも残っていれば次のページとしてプ

リントアウトされるようにしたいです。(aki)

 すいませんやっつけで追加修正。
 あまりスマートな方法ではないですが、ご所望の通り実行されるはずです。
 どなたかスマートに修正していただけると。

 '-------
Option Explicit
Sub Macro1()
Dim i As Integer
Dim MyR As Long, MyLp As Integer
    Sheets.Add
    ActiveSheet.Name = "temp"
    Sheets("Sheet2").Activate
    With Sheets("Sheet1")
        .Range("A1").CurrentRegion.Copy Destination:=Sheets("temp").Range("A1")
    End With
    With Sheets("temp")
        MyR = .Cells(Rows.Count, 1).End(xlUp).Row - 1
    End With
    MyLp = MyR Mod 30
    If MyLp = 0 Then
        MyLp = Int(MyR / 30)
    Else
        MyLp = Int(MyR / 30) + 1
    End If
    For i = 1 To MyLp
        With Sheets("temp")
            .Range("A" & (i - 1) * 30 + 2 & ":L" & i * 30 + 1).Copy Destination:=Sheets("Sheet2").Range("A4")
        End With
    If MsgBox("印刷しますか？：　" & i & "枚目", vbOKCancel + vbInformation, "印刷確認") = vbOK Then
        Sheets("Sheet2").PrintOut
    Else
        Application.DisplayAlerts = False
        Sheets("temp").Delete
        Application.DisplayAlerts = True
        Exit Sub
    End If
    Next i
    Application.DisplayAlerts = False
    Sheets("temp").Delete
    Application.DisplayAlerts = True
End Sub

 '-----------
wing000

 >キリキさんのコードを別のbookで確認したところ何もおこりませんでした。
 あれまｗ
 それは残念。。。
　
 プリントする命令まではしていませんでしたが、、、
 Sheet2にも、何も出ませんでした？
　
 （キリキ）（〃⌒o⌒)b

キリキさんありがとうございました。

　>MyA = .Range("A1", .Range("B" & .Rows.Count).End(xlUp))

これってB列までってことですね。AからBは列幅が小さいことと間に合わせで作ったリス

トだったので空白が多くて、見落としてしまいました。"B"のところを"L"に変えて

みたら希望通りに転記されていました。ごめんなさい。自分にはみたこともないコード

が書かれていて、とてもわかりません。理解できないまでも自分なりにいじって

少しでも解読できたらと思います。ありがとうございました。(aki)

wing000さん、長いことお付き合いいただきましてありがとうございました。

とても、無理だと思っていた処理が実現できてうれしいです。Sheet1のリストのセルに

色つきがあるのでそれがSheet2に残ってしまうことや、一度印刷の是非を聞いたら最後

まで印刷できるように自分で考えてやってみようと思います。本当にありがとうござい

ました。(aki)

 あれれ。。。
 L列って書いてありましたね～
　
 またまた、失敗しました・・・
　
 ごめんなさいねｍｍ
 （キリキ）（〃⌒o⌒)b

 あっ、遅かった。
 せっかくなので・・・なんて書いてたら
 キリキさんとも衝突☆

 wing000さんのをぱくっと頂いて
 気になる所は「Application.RoundUp」
 を使うのはどうでしょう。

 '------
Sub Pacro1()
Dim i As Integer, ii As Integer
Dim MyR As Long, MyLp As Integer
　
    Worksheets.Add before:=Worksheets(1)
    Sheets("Sheet1").Range("A1").CurrentRegion.Copy Destination:=Sheets(1).Range("A1")
    MyR = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row - 1
    MyLp = Application.RoundUp(MyR / 30, 0)
　    
    For i = 1 To MyLp
        ii = i * 30 + 1
        With Sheets("Sheet2")
            .Range("A4:L33").Value = Sheets(1).Range("A" & ii - 29 & ":L" & ii).Value
            .PrintPreview
'            .PrintOut
        End With
    Next i
    Application.DisplayAlerts = False
    Sheets(1).Delete
    Application.DisplayAlerts = True
End Sub
 '------

 ちなみに、
 ＞Sheet1のリストのセルに色つきがある
 のは反映されません。
　
　
 そうそう、文頭を半角スペースで始めると
 改行が反映されますよ。

 ←この部分に、半角スペースが入っています。
=←ここ。

 (HANA)　コード少し変更しました。22:58

 HANAさんぱくっとさくっとスマート修正ありがとです。m(_ _)m

 (aki)さん。(HANA)さん ＆ (キリキ)さんコード参考に自己追加、修正等などがんばってください。

wing000

 wing000さん、とんでもありません。
 すっかり美味しく頂きました。

 でも引き算間違えてるんですよね・・・。
 ごめんなさい、修正しときます。

 よく考えると、作業用シートは作業用にしか使わないので
 1行目をキッパリ削除しておけば　計算間違えも無かったのかも。

 (HANA)

 >wing000さん、とんでもありません。
 本当です。。。
 お二人のスキルのほうが上ですよ・・・
　
 σ(^o^;)も、精進精進ｂ
　
 （キリキ）（〃⌒o⌒)b

 ＞お二人のスキルのほうが上ですよ・・・
 そうですよね。
 私はいつでもキリキさんの後ろを
 もそもそとついて行ってます。

 ちなみに、適当につけた「ii」と言う変数ですが
 wing000さんの書き方も真似ると「MyPlr」ですかね？
 それとも　My + 二文字　にして「MyPr」？

 (HANA)

 HANAさんやwing000さんの背中を見つめつつｗ
 上手い方法が見つかりませんでしたので、ループして対応しましたｂ
　
Sub test()
Dim MyA As Variant, x() As Variant
Dim Rng As Range, Tbl As Range
Dim i As Long
Dim n As Integer, c As Integer, j As Integer
    With Worksheets("Sheet1")
        MyA = .Range("A1", .Range("L" & Rows.Count).End(xlUp))
        Set Tbl = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        ReDim x(1 To 30, 1 To UBound(MyA, 2))
        c = 0: j = 5
        For Each Rng In .Range(Tbl.Address(0, 0))
            c = c + 1
            If c > 30 Then
                Worksheets("Sheet2").Range("A1").Offset(j - 1).Resize(30, UBound(MyA, 2)) = x
                j = j + 34: c = 0
                ReDim x(1 To 30, 1 To UBound(MyA, 2))
            Else
                For n = 1 To UBound(MyA, 2)
                    x(c, n) = MyA(Rng.Row, n)
                Next n
            End If
        Next Rng
        Worksheets("Sheet2").Range("A1").Offset(j - 1).Resize(30, UBound(MyA, 2)) = x
    End With
    Set Tbl = Nothing
    Erase MyA, x
End Sub
　　
 ※プリントアウトはしていませんので、ご自身で印刷設定して【印刷】をかけてください。
　
 #オートフィルタは、フィルタ抽出したものだけを取得する方法はコピーしかないのでしょうかね～？
  誰かご存知の方がいらっしゃいましたら、教えてくださいｍｍ
　
 （キリキ）（〃⌒o⌒)b

 検証不足でした。。。
 件数が多いと、途中までしか引っ張ってきませんね・・・
　
 Set ステートメントには、限界があるのね？？？
 参照範囲の文字列が255文字までのようですね。。。
 （キリキ）（〃⌒o⌒)b

 キリキさん　こんにちは

 >Set ステートメントには、限界があるのね？？？
 > For Each Rng In .Range(Tbl.Address(0, 0))
　　　　　　　　　　　↑
　 　　　　　　　　　ここ、単にこれではダメですか？　(A列限定なのでよさそうに見えるのですが)
　　　　　　　　　　　　　　　　　　　　　　　↓
 　　　　　　　　　　　　　　 For Each Rng In Tbl

 (半平太)

 こんなんでどうでっか？
 60000データで3秒弱かかりますけどなぁ。
 　　　　（弥太郎）
 '---------------------
 Sub aki()
    Dim i As Long, j As Integer, n As Integer, u As Integer, tbl, x, y
    With Sheets("sheet1")
        tbl = .Range("a2").Resize(.Range("a" & Rows.Count).End(xlUp).Row - 1, 12).Value
        ReDim x(1 To UBound(tbl, 1) \ 30 + IIf(UBound(tbl, 1) Mod _
                        30 = 0, 0, 1), 1 To 30, 1 To UBound(tbl, 2))
        j = 1
        For i = 1 To UBound(tbl, 1)
            If Not .Rows(i + 1).Hidden Then
                u = u + 1
                For n = 1 To UBound(tbl, 2)
                    x(j, u, n) = tbl(i, n)
                Next n
            End If
            If u = 30 Then j = j + 1: u = 0
        Next i
    End With
    For i = 1 To j
        ReDim y(1 To 30, 1 To UBound(tbl, 2))
        For u = 1 To 30
            For n = 1 To UBound(tbl, 2)
                y(u, n) = x(i, u, n)
            Next n
        Next u
        Sheets("sheet2").Range("a1").Offset((i - 1) * 30 + i * 3).Resize(30, UBound(y, 2)) = y
    Next i
 End Sub

 >ここ、単にこれではダメですか？　(A列限定なのでよさそうに見えるのですが)
 そうですよね＾＾；
 お恥ずかしいｗ
　
 >60000データで3秒弱かかりますけどなぁ。
 さすが、ししょ～
 ってことは、やっぱりフィルタ後だけのデータって取得できないんですね・・・
 せっかくのフィルタですから、何とかなればと思ったんだけど・・・
　
 さらに、3行おきだった・・・orz
　
 （キリキ）(〃⌒o⌒)b

 一旦ダミーシートにコピーして、それからになりまんなぁ。
 せやから、コピーを使わない方法ですとあんな塩梅になりますが、フィルターなしに
 して、検索だけでこなしても時間はそれほど変わりまへんワ。結果的に全てのセルを
 検索しとるわけですから・・・。
 　　　　　　　（弥太郎）

コメント返信：

[ 一覧(最新更新順) ]

[[20080330111413]] 『3行おきに30行ずつの転記』（aki） ページの最後に飛ぶ

[[20080330111413]]　『3行おきに30行ずつの転記』（aki）　ページの最後に飛ぶ