ブック間のコピー(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使用です
回答1件
あなたの回答
tips
プレビュー