[[20121023164130]]　『貼付行を飛ばす』（miyama）　ページの最後に飛ぶ

『貼付行を飛ばす』（miyama）

 下記コードはsheet1の数値をsheet4に転記します。
 17行目から２行空けて貼り付けるコードですが、６個貼り付けたら
 60行目から２行空けて貼り付け、６個貼り付けたら
 105行目から２行空けて貼り付け、６個貼り付けたら 
 150行目から１行空けて６個貼り付ける
 コードに修正したいのですが、ご指導お願いします
 以下のような形です
 (e15)日付(k15)科目(n15)金額
 (e17)日付(k15)科目(n17)金額
 (e19)日付(k15)科目(n19)金額
 (e21)日付(k15)科目(n21)金額
 (e23)日付(k15)科目(n23)金額
 (e25)日付(k15)科目(n25)金額
 (e60)日付(k60)科目(n60)金額
 (e62)日付(k62)科目(n62)金額
 (e64)日付(k64)科目(n64)金額
 (e66)日付(k66)科目(n66)金額
 (e68)日付(k68)科目(n68)金額
 (e70)日付(k70)科目(n70)金額
 (e105)日付(k105)科目(n105)金額
 (e107)日付(k107)科目(n107)金額
 (e109)日付(k109)科目(n109)金額
 (e111)日付(k111)科目(n111)金額
 (e113)日付(k113)科目(n113)金額
 (e115)日付(k115)科目(n115)金額
 (e150)日付(k150)科目(n150)金額
 (e152)日付(k152)科目(n152)金額
 (e154)日付(k154)科目(n154)金額
 (e156)日付(k156)科目(n156)金額
 (e158)日付(k158)科目(n158)金額
 (e160)日付(k160)科目(n160)金額

 Sub 貼り付け()
 Dim 行 As Long
 Dim 貼付行 As Long
 Dim 科目設定 As String
 Dim 帳 As Worksheet
 Dim 複写 As Worksheet
 Set 帳 = Worksheets("sheet4")
 Set 複写 = Worksheets("sheet1")
 行 = 3 
 貼付行 = 17 
 Do Until 複写.Cells(行, 1).Value = "" '１列目に値が無ければ終了
 帳.Cells(貼付行, 5).Value = 複写.Cells(行, 1).Value 
 If Sheets("sheet1").Range("a15").Value <> "" Then
 帳.Cells(貼付行, 11).Value = 複写.Cells(行, 10).Value 
 End If
 帳.Cells(貼付行, 14).Value = 複写.Cells(行, 9).Value
 貼付行 = 貼付行 + 2   
 Loop
 End Sub
 Excel2007 Windows 7

 回答の前に。

 貼り付け元の行変数 "行" はカウントアップしていないけど、↑のコードは実際に動かしたコードじゃないんだね？

 追記）説明文とコードは１７行目からとなっているけど、サンプルは１５行目からになっているね。
 　　　実際は、どちらが正しいの？

 (ぶらっと)

 ぶらっと様　申し訳ありません
 行 = 行 + 1 が抜けていました、申し訳ありません

 Sub 貼り付け()
 Dim 行 As Long
 Dim 貼付行 As Long
 Dim 科目設定 As String
 Dim 帳 As Worksheet
 Dim 複写 As Worksheet
 Set 帳 = Worksheets("sheet4")
 Set 複写 = Worksheets("sheet1")
 行 = 3 
 貼付行 = 17 
 Do Until 複写.Cells(行, 1).Value = "" '１列目に値が無ければ終了
 帳.Cells(貼付行, 5).Value = 複写.Cells(行, 1).Value 
 If Sheets("sheet1").Range("a15").Value <> "" Then
 帳.Cells(貼付行, 11).Value = 複写.Cells(行, 10).Value 
 End If
 帳.Cells(貼付行, 14).Value = 複写.Cells(行, 9).Value
 貼付行 = 貼付行 + 2   
 行 = 行 + 1
 Loop
 End Sub
 >説明文とコードは１７行目からとなっているけど、サンプルは
 >１５行目からになっているね。
 申し訳ありません１７です

  miyama

 >150行目から１行空けて６個貼り付ける

 サンプルでは、ここも２行おきなので、サンプルが正しいとして。
 転記元領域等、コードから推測しているので誤解していたら指摘乞う。

 Sub Sample()
    Dim rowArray As Variant
    Dim x As Long
    Dim eFlag As Boolean
    Dim 行 As Long
    Dim 貼付行 As Variant   '★型変更
    Dim 帳 As Worksheet
    Dim 複写 As Worksheet

    Application.ScreenUpdating = False

    Set 帳 = Worksheets("Sheet4")
    Set 複写 = Worksheets("Sheet1")

    rowArray = Array(17, 60, 105, 150)
    行 = 3

    '貼付先領域のクリア
    For Each 貼付行 In rowArray
        帳.Cells(貼付行, "E").Resize(11).ClearContents
        帳.Cells(貼付行, "K").Resize(11).ClearContents
        帳.Cells(貼付行, "N").Resize(11).ClearContents
    Next

    '貼付実行
    For Each 貼付行 In rowArray

        For x = 1 To 6
            If IsEmpty(複写.Cells(行, 1).Value) Then
                eFlag = True
                Exit For
            End If
            帳.Cells(貼付行, "E").Value = 複写.Cells(行, "A").Value
            帳.Cells(貼付行, "K").Value = 複写.Cells(行, "J").Value
            帳.Cells(貼付行, "N").Value = 複写.Cells(行, "I").Value
            行 = 行 + 1
            貼付行 = 貼付行 + 2
        Next
        If eFlag Then Exit For
    Next

    帳.Select
    Application.ScreenUpdating = True
    MsgBox "貼付完了"

 End Sub

 (ぶらっと)

 ぶらっと様　ありがとうございます
 感謝です
 １つお願いしてもよろしいでしょうか
 貼付先領域のクリアとして、下記コードですが,大変便利です
 いちいちセルを削除するコードが必要ないですから。
 ただ、エラーになります。
 説明不足でした。
 "e"は結合セルでして、e列からＪ列
 "k"はk列からm列
 "n"はn列からx列 です
 結合されたセルの一部を変更することはできません　とエラー表示されます
 どうかいまひとつご指導お願いします
 For Each 貼付行 In rowArray
 帳.Cells(貼付行, "E").Resize(11).ClearContents
 帳.Cells(貼付行, "K").Resize(11).ClearContents
 帳.Cells(貼付行, "N").Resize(11).ClearContents
 Next
 miyama

Resize(11)はResize(11,1)の略です。
それぞれ列数を勘定して
Resize(11,n)の n の数値を設定してください。
（みやほりん）

 衝突

 みやほりんさんと同じ回答だけど

        帳.Cells(貼付行, "E").Resize(11, 6).ClearContents
        帳.Cells(貼付行, "K").Resize(11, 3).ClearContents
        帳.Cells(貼付行, "N").Resize(11, 11).ClearContents

 (ぶらっと)

 みやほりん様　ありがとうございます

 ぶらっと様
 たいへん時間おかけしました
 ありがとうございます

 miyama

コメント返信：

[ 一覧(最新更新順) ]

[[20121023164130]] 『貼付行を飛ばす』（miyama） ページの最後に飛ぶ

[[20121023164130]]　『貼付行を飛ばす』（miyama）　ページの最後に飛ぶ