[[20060805142107]]　『例えば？』（いちご) 　ページの最後に飛ぶ

『例えば？』（いちご)

 Sheet1に受付簿とします。
 依頼があった順に打ち込んでいきます。
   A    　 　B　　　 C　　   D　　　 E    　  F   　　G
 依頼先   行き先　 品 名   出発日　到着日   台数    会社名
   あ　　　　い　　　う　　　8/1　　8/3　　　 1       え

 Sheet2を１ヵ月分のデータとします。
 Sheet1のFの台数の所に3と入力したら、Sheet2のデータにA～Eまで3台分ほど
 自動でコピー出来ないかな？と思いまして。。。。
 コピペすれば良いだけなのでしょうが、こう言う事も出来るのかな？？
 と思いました。
 教えて頂ければ嬉しいです。

 >自動でコピー出来ないかな？と思いまして。。。。
 自動でとなると、マクロになりますね～♪
　
 試しに作ってみましたが、あっていますでしょうか？
　
Option Explicit
　
Sub test()
Dim MyA As Variant, MyAry() As Variant
Dim i As Long, n As Long, c As Long
    With Worksheets("Sheet1")
        MyA = .Range("A1").CurrentRegion
        n = Application.Sum(.Range("F:F"))
        ReDim MyAry(1 To n)
        n = 0
        For i = 2 To UBound(MyA, 1)
            c = 0
            Do
                c = c + 1: n = n + 1
                MyAry(n) = Array(MyA(i, 1), MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5))
            Loop Until c = MyA(i, 6)
        Next i
    End With
    With Worksheets("Sheet2")
        .Cells.ClearContents
        .Range("A1:E1") = Array(MyA(1, 1), MyA(1, 2), MyA(1, 3), MyA(1, 4), MyA(1, 5))
        .Range("A2").Resize(UBound(MyAry, 1), 5) = Application.Transpose(Application.Transpose(MyAry))
    End With
    Erase MyA, MyAry()
End Sub
　
 ※Sheet2 の D:E列の書式設定は変更してあるものとしています。
　
 （キリキ）(〃⌒o⌒)b

 キリキさん早速ご返信有難うございます！
 やってみたのですが。。。
 Next i　でインデックスが有効範囲でありませんとなります。。。。
 なぜなのでしょうか？？？？？

 いちごさん
 ご質問の目的は、台数分の行を確保してその行ごとにデータを記入する
 (Serial No, Description 等)ようなことですか？
 その場合、入力済みの台数を変更することもありますか？　(seiya)

 seiyaさんご返信有難うございます。
 Sheet1に
    A    　  B　　　 C　　   D　　　 E    　  F   　　G
 依頼先   行き先　 品 名   出発日　到着日   台数    会社名
   あ　　　　い　　　う　　　8/1　　8/3　　　 3       え
 と入力すれば  
 Sheet2に
 　 A    　  B　　　 C　　   D　　　 E    　  F   　　G
 依頼先   行き先　 品 名   出発日　到着日   台数    会社名
   あ　　　　い　　　う　　　8/1　　8/3　　　 1       え
　 あ　　　　い　　　う　　　8/1　　8/3　　　 1       え
   あ　　　　い　　　う　　　8/1　　8/3　　　 1       え
 となります。台数の変更も有り得ます。

 ということは、 H列以降の入力は無いのですね？

 >インデックスが....
 Sheet1に途中空白行はありませんか？　(seiya)

 途中に空白行があります。。。。。。
 空白行があるとダメなのですね。。。。

 あっても大丈夫です、が、
 キリキさんにコードを変更してもらう必要があります。(seiya)

 変更箇所だけ書きますね

 1) MyA = .Range("a1").CurrentRegion -> MyA = .Range("a1",.Range("a" & Rows.Count).End(xlUp)).Resize(,7).Value

 2) c = 0 の一行上に If MyA(i,6) > 0 Then を挿入

 3) Loop Until c = MyA(i,6) の一行下に End If を挿入

 これで試してみてください　(seiya)

 ありゃま！
 やっと手が空いて来て見てビックリ！
 seiyaさんありがとうございます＾＾
　
 >MyA(i,6) > 0 Then 
 そうですよね～
 こういう気の配り方がσ(^o^;)には足りないんだな・・・
　
 いちごさん、がんばってください＾＾
　
 今読み返したら当初は、
 >Sheet2のデータにA～Eまで
 だったのに、
 >Sheet2に
 > 　 A    　  B　　　 C　　   D　　　 E    　  F   　　G
 > 依頼先   行き先　 品 名   出発日　到着日   台数    会社名
 になったのね？
　
 その辺も含めて、seiyaさんのフォロー追加版を！
　
Sub test()
Dim MyA As Variant, MyAry() As Variant
Dim i As Long, n As Long, c As Long
    With Worksheets("Sheet1")
        MyA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 7).Value
        n = Application.Sum(.Range("F:F"))
        ReDim MyAry(1 To n)
        n = 0
        For i = 2 To UBound(MyA, 1)
            If MyA(i, 6) > 0 Then
                c = 0
                Do
                    c = c + 1: n = n + 1
                    MyAry(n) = Array(MyA(i, 1), MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5), 1, MyA(i, 7))
                Loop Until c = MyA(i, 6)
            End If
        Next i
    End With
    With Worksheets("Sheet2")
        .Cells.ClearContents
        .Range("A1:G1") = Array(MyA(1, 1), MyA(1, 2), MyA(1, 3), MyA(1, 4), MyA(1, 5), MyA(1, 6), MyA(1, 7))
        .Range("A2").Resize(UBound(MyAry, 1), 7) = Application.Transpose(Application.Transpose(MyAry))
    End With
    Erase MyA, MyAry()
End Sub
　
 （キリキ）（〃⌒o⌒)b

 seiyaさん、キリキさん有難うございます。
 これから続きに取り掛かろうと思って除いたら。。。。
 頑張ります！！！取りあえずは御礼をと思いました！
 また疑問が出てきたら質問させて下さい！！

 あの。。。上手くいかなくて・・・
 #N/Aと表示されるのですが。。。
 何故なのでしょうか？？？？

 表のレイアウトは、上の例題どおりですよね？
　
 #N/Aが出るのは全部ですか？
　
 （キリキ）(〃⌒o⌒)b

 とらんすぽーずを使わない別案・ｗ３阿
 (ROUGE)
'----
Sub Strawberry()
Dim tbl, ans, i As Long, j As Long, k As Long, n As Long
With Worksheets("Sheet1")
    tbl = .Range("A1:G" & .Range("G" & Rows.Count).End(xlUp).Row)
    n = WorksheetFunction.Sum(.Range("F:F").Value)
    If n > Rows.Count - 1 Then MsgBox "多すぎなので中止！", vbExclamation: Exit Sub   '<--追加
End With
ReDim ans(1 To n + 1, 1 To 7)
For j = 1 To 7
    ans(1, j) = tbl(1, j)
Next
k = 1
For i = 2 To UBound(tbl, 1)
    For n = 1 To tbl(i, 6)
        k = k + 1
        For j = 1 To 7
            If j = 6 Then
                ans(k, j) = 1
            Else
                ans(k, j) = tbl(i, j)
            End If
        Next j
    Next n
Next i
With Worksheets("Sheet2")
    .Range("A:G").ClearContents
    .Range("A1").Resize(UBound(ans, 1), 7).Value = ans
    .Range("D:E").NumberFormatLocal = "m/d"
End With
Erase tbl, ans
End Sub

 キリキさん｡返信有難うございます｡
 表のレイアウトは変わりません｡
 A～Cは空白でD～Gまでは,台数が4台なら4行、#N/Aと表示されます。
 ROUGEさん｡ご提案有難うございます｡
 これから,お勉強します！！！

 一行追加しますた～
 (ROUGE)

 ROUGEさんに質問なのですが。。。。
 何度試しても32台までは自動でコピーされるのですが、それ以降はコピーされません。
 何故でしょう？？？

 もう一度確認！
　
Sheet1	[A]	[B]	[C]	[D]	[E]	[F]	[G]
[1]	依頼先	行き先	品　名	出発日	到着日	台数	会社名
[2]	あ	い	う	8/1	8/3	3	え
[3]	か	き	く	8/7	8/7	2	け
[4]	さ	し	す	8/13	8/11	1	せ
[5]	た	ち	つ	8/19	8/15	2	て
　
 こんなレイアウトですよね？
 どこか違うところあります？
 例えば、どこかの行に空欄があるとか。。。
　
 色々なパターンで試してみたのですが、、、
 エラーがでて、止まることはあったけど「#N/A」が出ることはなかったんですよね・・・
 （キリキ）(〃⌒o⌒)b

 > どこか違うところあります？
 違うとこめっけｗ
 4行目と5行目は、タイムトラベルしてます～（不具合関係ないし・・・）
 (ROUGE)

 キリキさん、お手数お掛けしてます・・・
 １から読み直して色々試していたら出来ました！！！
 Sheet2のH以降に数式を入力したのですが、マクロを実行すると
 数式も消えました。。。
 マクロを実行しても関数は消えないと聞いた事があった様な・・・
 勘違いだったのでしょうか？？？？
 有難うございました！

 >Sheet2のH以降に.....
 だから最初に質問したじゃないですか...
 それだと、後から台数を変更するとずれてしますのです　(seiya)

 でももし、H列以降の数式がA:Gの結果を受けた数式なら。

 .Cells.ClearContents を
 .Range("a:g").ClearContents に変更すれば可能ですね (seiya)

 seiyaさん！
 便利だと思い後から数式を加えた次第でございます。
 ご返信頂いた、お陰で出来ました。
 本当に有難うございました。

 数式でよかったです。
 もし手入力だったら、コードまるっきり書き直しでしたね.. (seiya)

 seiyaさん、最後までフォローして頂いてありがとうございますm(_ _)m
　
 （キリキ）(〃⌒o⌒)b

コメント返信：

[ 一覧(最新更新順) ]

[[20060805142107]] 『例えば？』（いちご) ページの最後に飛ぶ

[[20060805142107]]　『例えば？』（いちご) 　ページの最後に飛ぶ