VBA コピーして次の値まで貼り付けを繰り返す

Question

（A列）　　　　（B列）　　　　　（C列）　　　　      ・・・・
(1行目)　　参照Excel名　　　コード　　　　　 ・・・・・・・
(2行目)　　①.xlsx              213423　　　　　・・・・・・・
(3行目)　　                        432153　　　　  ・・・・・・・
(4行目)　　                        352582
(5行目)　　②.xlsx              342213
(6行目)　　                        482397
(7行目)　　③.xlsx              584054
(8行目)　　④.xlsx              482093
(9行目)　　                        582857
(10行目) 　                        582752
(11行目) 　                        853875

~~~~~~~~~~~~~~~~~~~~~~~~
エクセルが上記の様な横長の表になっていて、
A列の”参照Excel名”が、A1セルに入力されています。
A2の”①.xlsx”をコピーして、その下のA3から次の値があるA5の一つ前(→A4)まで貼り付ける。
次の値のA5をコピーして、その下のA6から次の値があるA7の一つ前(→A6)まで貼り付ける。
次の値のA7をコピーして、その下に次の値があるのでコピーしない。
次の値のA8をコピーして、その下のA9から次の値の一つ前まで貼り付ける、但し、B列の最終行まで次の値がない場合は、B列の最終行と同じ行数まで貼り付ける。

というような流れでマクロを組みたいと思ったのですが、うまくいきません。
（空白の数は変動します。）

ちなみに、他の処理もありますが、以下のマクロを組んでいます。
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub 原料の在庫表をコピー()
    Dim frWB As Workbook      'コピーするブック用
    Dim toWB As Workbook      '貼り付け先のブック用
    Dim r As Long             '貼り付け先セルの行番号を取得用
    Dim cnt As Long           'コピーするブックのデータ件数を取得用
    Dim Filename As String    '棚卸データの名前用
    Dim myData As String      '棚卸データのエクセル取得用
    
    Set toWB = ThisWorkbook   'このブックを代入
    
    'Dirでブックを検索してmyFileへ代入
    myData = Dir(toWB.Path & "\原料棚卸在庫表\*.xls?")
    
    'myDataが無くなるまで処理を繰り返す
    Do While myData <> ""
    
    '処理内容
    
        '検索したエクセルを開く
        Set frWB = Workbooks.Open(toWB.Path & "\原料棚卸在庫表\" & myData)
        
        'ActiceWorkbookオブジェクトのName情報を取得し、変数「FileName」に格納する
        Filename = ActiveWorkbook.Name
        
        'このブックの先頭シートのB列の一番上のセルの1つ下のセルから一番下のセルの行数をｒに代入
        r = toWB.Worksheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1).Row

            
        'コピーするブックの必要データ部分の選択、コピー
        With frWB.Worksheets(3).Cells(9, 2).CurrentRegion
            cnt = .Rows.Count - 1
            .Offset(1).Resize(cnt).Copy
            
            '値で貼り付け
            toWB.Worksheets(1).Cells(r, "B").PasteSpecial xlPasteValues
            '棚卸データ名を貼り付け
            toWB.Worksheets(1).Cells(r, "A") = Filename
            'コピーモードの終了
            Application.CutCopyMode = False
            
                
        End With
        
        frWB.Close
        myData = Dir()
        
        
    Loop
    
    '合計の行を削除
    
    Dim rng As Range, i As Long
    Set rng = Range("A1").CurrentRegion  '表全体を変数rngに代入
    
    '表の一番下から1行ずつ確認して表の2行目でストップする
    For i = rng.Rows.Count To 2 Step -1
    
        '表のi行2列目に合計とある行があった場合
        If rng.Cells(i, 2).Value = "合計" Then
        
            'そのi行を削除し、下のセルを上にシフトする
            rng.Rows(i).Delete Shift:=xlShiftUp
            
        End If
        
    Next
    
End Sub

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
できれば、中盤↓の棚卸データ名を貼り付けのところで、コピペできればいいのですが･･･

            '棚卸データ名を貼り付け
            toWB.Worksheets(1).Cells(r, "A") = Filename


説明が上手くできずに申し訳ありませんが、
どなたかご一考いただけると幸いです。
よろしくお願いいたします。

Qchan1962 · Accepted Answer

＃１です
＞A3～A14までA2と同じ名前が入るようにしたいのです。
と言う事は、cnt　を　.Offset(1).Resize(cnt).Copy　同様に使えば良いかと

'棚卸データ名を貼り付け
            toWB.Worksheets(1).Cells(r, "A").Resize(cnt).Value = Filename

Qchan1962 · Answer

>実行時エラーに
誤解を与えてしまったかも知れませんので　追記すると

With frWB.Worksheets(3).Cells(9, 2).CurrentRegion
cnt = .Rows.Count - 1
.Offset(1).Resize(cnt).Copy

必ず見出し行などで（複数行）あるのであれば、
frWB.Worksheets(3).Cells(9, 2).CurrentRegion.Rows.Countは2以上になり、cnt = .Rows.Count - 1　の時のcntの値は1以上ですね。
これなら問題はありませんが、
もし、Cells(9, 2).CurrentRegionが1行しかなかったらcntは0となり
Resize(0)は　1004エラーになると言う事です。

.Offset(1)から推測するに
そのような表組にはなっていないようですので忘れてください。

Qchan1962 · Answer

こんにちは
ご質問自体が良く分からずなのですが、
示されているコードで　なさりたい事が出来ていない部分

＞次の値のA7をコピーして、その下に次の値があるのでコピーしない。

をどうすれば良いかと言う事でしょうか

この場合は、A7の行が要らないと言う事と思いますので
コピペせずに次のファイルに行けばよい事になりますね

コードを読むと・・実行時エラーにならないかな？あ、見出しがあるのですね

With frWB.Worksheets(3).Cells(9, 2).CurrentRegion
            cnt = .Rows.Count - 1
            .Offset(1).Resize(cnt).Copy

ここで③.xlsxの場合、cntは1ですね　1行の場合はいらない・・で良いのなら、

With frWB.Worksheets(3).Cells(9, 2).CurrentRegion
            cnt = .Rows.Count - 1
            If cnt > 1 Then
            .Offset(1).Resize(cnt).Copy
            '値で貼り付け
            toWB.Worksheets(1).Cells(r, "B").PasteSpecial xlPasteValues
            '棚卸データ名を貼り付け
            toWB.Worksheets(1).Cells(r, "A") = Filename
            'コピーモードの終了
            Application.CutCopyMode = False
            End If
        End With
とすれば　③.xlsx　は出力（コピペ）されないと思います。

、、、必ず、合計行もあるのかな？削除していると言う事は・・
必ずあるなら、If cnt > 2 Then　かな、、
もっとも合計行が必ずあるなら、
cnt = .Rows.Count - 2
If cnt > 1 Then
でも良いのか・・

全然的外れでコードに関係なく新たに示されている表のコピー方法を知りたいのかな・・ペースト先無いから違うと思いますが、、、

良く分からずで未検証なのであくまで参考程度でね

VBA コピーして次の値まで貼り付けを繰り返す

＃１です

>実行時エラーに

こんにちは

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング