質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.25%

ブック間のコピー(2カ所)をしたいです

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 63

kogukoguT

score 1

ブック間のコピー(2カ所)をしたいです。

マクロ初心者です。複数ある申込書を一つのデータにまとめるのに転記作業に時間がかかっているため
仕事の量を軽減するために始めたものの行き詰ってしまい、
調べてもどこが原因かわからず2日くらい悩んでいます。

ネットで「複数フォルダ 転記 マクロ」で検索してでてきたVBAを参考に作成しています。
失礼な聞き方と存じますが助けていただけますでしょうか。

コピー元から二カ所コピーし、コピー先のブックに二カ所ペーストをしたいです。
一カ所のコピーはできたのですが、もう一つができなく困っています。

下記4つをやろうとしています。

(1)コピー元は同じフォーマットで複数存在し、コピー先と同じフォルダに入っています
(2)コピー元がなくなるまでコピー先の空白の行に繰り返し転記
(3)1つ目のコピー(copy1とします)はCOUNTA関数で数えたセルの数(copy2の数です)だけコピー先に転記する
(4)1つ目のコピー、2つ目のコピー(copy2とします)ともに空白の行に転記する

このうちcopy2の転記はできたのですが、copy1の転記ができません。

発生している問題・エラーメッセージ

2つ目のコピーはクリップボードを宣言してからやったところ
うまくできたのですが、1つ目のコピーがうまくいかず、

エラー9「インデックスが有効範囲にありません」


とでてしまいます。

該当のソースコード

Dim OpenExcelFileName, ExcelFileName, ExcelFilePath, FileName As String
Dim i  As Long

   'ダイアログを表示取り込むフォルダーにあるファイルを選択します。            
    OpenExcelFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")  
            '指定したファイルパスからファイル名を代入します。
       '指定したファイルパスを指定します。(ファイルパスからファイル名を取り除く)
            If OpenExcelFileName <> "False" Then
                ExcelFileName = Dir(OpenExcelFileName)  
                ExcelFilePath = Replace(OpenExcelFileName, ExcelFileName, "")  

                MsgBox ExcelFilePath & "この選択フォルダからデータを読込み込みます。"
            Else
                MsgBox "キャンセルされました"
         'キャンセルでプログラムを終了します。 
                Exit Sub  
            End If


'指定したフォルダーから一件目のEXCELファイルを指定します。
FileName = Dir(ExcelFilePath & "*.xls?")

'カレントフォルダに存在するExcelファイルを全て読み込む
Do While FileName <> ""
Workbooks.Open FileName:=ExcelFilePath & FileName, ReadOnly:=True, UpdateLinks:=0

i = 1

 'ここから下をコピペ作業

    'copy1のコピー
     'copy2の数だけコピペする
        Dim num As Integer
            num = WorksheetFunction.CountA(Sheets("コピー元").Range("b10:b12"))
            For j = 1 To num
            Dim last_row As Long
            last_row = Sheets("コピー先").Cells(Rows.Count, 2).End(xlUp).Row              '→ここでエラー9がでます。
            Sheets("コピー元").Range("H5:M5") = Sheets("コピー先").Cells(last_row + j, 2)

        Next j



    'copy2のコピー

     Dim clipboard
     clipboard = Sheets("コピー元").Range("B10:M13")

     ActiveWindow.Close


     '空白のセルまで移動して、そこに転記
            Dim last_row1 As Long
            last_row1 = Sheets("コピー先").Cells(Rows.Count, 7).End(xlUp).Row
            Cells(last_row1 + 1, 7).Select
              Sheets("コピー先").Range(Cells(last_row1 + 1, 7), Cells(last_row1 + 4, 18)) = clipboard



    '次のExcelファイルを取得
   FileName = Dir()

    '行数をカウント
    i = i + 1

Loop


End Sub

試したこと

ここに問題に対して試したことを記載してください。

Dim copy1 as String
Sheets("コピー元").Range("H5:M5") = copy1
num = WorksheetFunction.CountA(Sheets("コピー元").Range("b10:b12"))
For j = 1 To num
Dim last_row As Long
last_row = Sheets("コピー先").Cells(Rows.Count, 2).End(xlUp).Row
Sheets("コピー先").Cells(last_row + j, 2) = copy1

でもやってみましたが、
’ last_row = Sheets("コピー先").Cells(Rows.Count, 2).End(xlUp).Row’
で同じくエラー9になってしまいます。

補足情報(FW/ツールのバージョンなど)

windows10, Office365使用です

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • meg_

    2020/05/23 01:22

    エラーが出る行の前に「Sheets("コピー先").Activate」を入れたらどうなりますか?

    キャンセル

  • kogukoguT

    2020/05/23 09:29

    添削してくださり誠にありがとうございます。
    ご提示くださったように入れてみましたが、「Sheets("コピー先”).Activate」でエラーが発生してしまいました。
    そこでhatena19様の回答にmeg_様のご提案を組み合わせたところ、うまく転記がいくようになりました。
    お知恵をかしてくださりありがとうございました!
    おかげさまで2時間かかってた仕事が1分せず終わりました。

    キャンセル

回答 1

checkベストアンサー

+1

コピー元のシートとコピー先のシートは別ブックということですよね。

ブックを明示的に指定しないと、アクティブブックが対象になります。
Workbooks.Openすると開いたブック(コピー元のブック)がアクティブになります。

last_row = Sheets("コピー先").Cells(Rows.Count, 2).End(xlUp).Row


はコピー元のブックが対象になりますが、コピー元ブックには、コピー先シートはないはずですので当然エラーになります。
アクティブブック前提のコードはやめて、ブックを明示的に指定するコードに変更しましょう。

'前略

'コピー先ブックを変数に格納
Dim wbTo As Workbook
Set wbTo = ThisWorkbook

'カレントフォルダに存在するExcelファイルを全て読み込む
Do While FileName <> ""
    'コピー元ブックを開いて変数に格納
    Dim wbFrom As Workbook
    Set wbFrom = Workbooks.Open(FileName:=ExcelFilePath & FileName, ReadOnly:=True, UpdateLinks:=0)

i = 1

 'ここから下をコピペ作業

    'copy1のコピー
     'copy2の数だけコピペする
        Dim num As Integer
            num = WorksheetFunction.CountA(wbFrom.Sheets("コピー元").Range("B10:B12"))
            For j = 1 To num
            Dim last_row As Long
            last_row = wbTo.Sheets("コピー先").Cells(Rows.Count, 2).End(xlUp).Row   'ここのエラーはなくなるはず 

            '↓このコードはおかしいので要修正
            Sheets("コピー元").Range("H5:M5") = Sheets("コピー先").Cells(last_row + j, 2)

        Next j


'以下同様に、対象ブックを省略せずに記述するように変更

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/05/23 09:44

    添削してくださり誠にありがとうございます。
    おっしゃる通り別のブックがコピー先になります。
    ブックを指定しないといけないとは全く考えにもありませんでした。
    コピペでマクロをしている者に優しくコードを書き直してくださり本当に助かります。

    コピペのやり方が良くなかったのか、頂いたコードでも同じところでデバックしてしまったのですが、
    ・デバックする手前に「wbTo. Activate」を入れる
    ・「=」で転記をするのではなく、「.Copy と.PasteSpecial」で転記する
    ようにしたらうまく動きました・・・!!!

    'copy1のコピー
    'copy2の数だけコピペする
    wbFrom. Activate

    Dim num As Integer
    num = WorksheetFunction.CountA(wbFrom.Sheets("コピー元").Range("B10:B12"))
    For j = 1 To num

    wbFrom. Sheets("コピー元”). Range("H5:M5"). Copy

    wbTo. Activate

    last_row = wbTo.Sheets("コピー先").Cells(Rows.Count,2).End(xlUp).Row

    wbTo.Sheets("コピー先”).Range(Cells(last_row + j, 2), Cells(last_row + j, 7)).PasteSpecial xlPasteValues

    Application.CutCopyMode = False


    この2週間スタックしていたのが嘘のようで、文字通り小躍りしてしまいました。
    お知恵を貸してくださり本当にありがとうございました。
    プロの方に勇気を出して質問してよかったです。
    なぜか繰り返し転記が「繰り返しの数*1行」空いて転記になっていましたが、最後に空白の行を削除することで完成いたしました。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.25%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる