現在ブックがA.xlsmとB.xlsxがあります。
A.xlsmがマクロ実行用のエクセルです。
1) A.xlsmのCells(r,1)の文字列のブックB.xlsxを開く(B.xlsxには(r,2)のシート名が存在します)
2) A.xlsmのCells(r,2)の文字列の新しいブックC.xlsxを作成する
3) B.xlsxのシートをC.xlsxの同じシート名にコピーする
*具体的にわかりやすく申し上げれば
A.xlsm (r,1) 天気 (r,2)20190227
B.xlsxには20190227というシートが存在しており、(1,1)に晴れと記載されている
C.xlsxに晴れというブック名を付して、B.xlsxの同じシート名の晴れという内容を
コピーしてきたい
ということになります。ループになっているの少しわかりづらいのですが
上記を意図したコードが"インデックス有効範囲エラー"がでてしまうのですが
原因と解決方法を教えてください。
宜しくお願い申し上げます。
Sub fileOpenAndCreate()
Dim fileName As String
Dim r As Long
Dim wb As Workbook
Dim oldPath As String
Dim newPath As String
r = 2
While Cells(r, 1) <> ""
oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & Cells(r, 1).Value
newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & Cells(r, 2).Value
Workbooks.Open (oldPath) '既にWBをOpenでも動作する仕様を確認
Worksheets(Cells(r, 2).Value).Activate
Set wb = Workbooks.Add
wb.SaveAs (newPath)
Worksheets(1).Name = Cells(r, 2).Value
Workbooks(oldPath).Worksheets(Cells(r, 1).Value).Copy After:=Workbooks(newPath).Worksheets(Cells(r, 1).Value)
r = r + 1
Wend
End Sub
修正後のコード
Sub fileOpenAndCreate()
Dim fileName As String
Dim r As Long
Dim oldPath As String
Dim newPath As String
Dim nWb As Workbook
Dim oWb As Workbook
Dim oWs As Worksheet
Dim tWs As Worksheet
Dim nWs As Worksheet
Set tWs = Worksheets("実行シート")
r = 2
While Cells(r, 1) <> ""
oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
'old------------
Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認
Set oWs = oWb.Worksheets(tWs.Cells(r, 2).Value)
'new------------
Set nWb = Workbooks.Add
nWb.SaveAs (newPath)
Set nWs = nWb.Worksheets(1)
nWs.Name = tWs.Cells(r, 2).Value
oWs.Copy After:=nWs(tWs.Cells(r, 2).Value)
r = r + 1
Wend
End Sub
再修正コード
Sub fileOpenAndCreate()
Dim fileName As String
Dim r As Long
Dim oldPath As String
Dim newPath As String
Dim nWb As Workbook
Dim oWb As Workbook
Dim oWs As Worksheet
Dim tWs As Worksheet
Dim nWs As Worksheet
Dim nWsTf As Worksheet
Set tWs = Worksheets("実行シート")
r = 2
While tWs.Cells(r, 1) <> ""
oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認
Set oWs = oWb.Worksheets(tWs.Cells(r, 2).Value)
MsgBox "Doesnt work" & r '↑ここでインデックスエラー
'new------------
Set nWb = Workbooks.Add
Set nWs = nWb.Worksheets("Sheet1")
oWs.Copy After:=nWs
Application.DisplayAlerts = False
nWs.Delete
Application.DisplayAlerts = True
'new tf------------
Set nWsTf = nWb.Worksheets(tWs.Cells(r, 2).Value)
nWsTf.Cells.Font.Name = "MS Pゴシック"
nWb.SaveAs (newPath)
r = r + 1
Wend
End Sub
-
気になる質問をクリップする
クリップした質問は、後からいつでもマイページで確認できます。
またクリップした質問に回答があった際、通知やメールを受け取ることができます。
クリップを取り消します
-
良い質問の評価を上げる
以下のような質問は評価を上げましょう
- 質問内容が明確
- 自分も答えを知りたい
- 質問者以外のユーザにも役立つ
評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。
質問の評価を上げたことを取り消します
-
評価を下げられる数の上限に達しました
評価を下げることができません
- 1日5回まで評価を下げられます
- 1日に1ユーザに対して2回まで評価を下げられます
質問の評価を下げる
teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。
- プログラミングに関係のない質問
- やってほしいことだけを記載した丸投げの質問
- 問題・課題が含まれていない質問
- 意図的に内容が抹消された質問
- 過去に投稿した質問と同じ内容の質問
- 広告と受け取られるような投稿
評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。
質問の評価を下げたことを取り消します
この機能は開放されていません
評価を下げる条件を満たしてません
質問の評価を下げる機能の利用条件
この機能を利用するためには、以下の事項を行う必要があります。
- 質問回答など一定の行動
-
メールアドレスの認証
メールアドレスの認証
-
質問評価に関するヘルプページの閲覧
質問評価に関するヘルプページの閲覧
checkベストアンサー
+1
アクティブ前提の作りになっているからのような気がします。
ブックをオープンした時点で、そちらのブックがアクティブになっていないでしょうか?
具体的な修正点としては、
単純にCells(r, 1)
とするのではなく、シート名を指定すべきです。Worksheets("hoge").Cells(r, 1)
など。
Worksheets(Cells(r, 2).Value).Activate
のところも、アクティブにするのではなく、シートオブジェクトを作成すべきです。
Set sh = Worksheets(Cells(r, 2).Value)
その後、そのオブジェクトを使って、セルの参照を行います。
sh.Cells(略)
こんな感じで全体的に明示的なコードに修正してみてどうなるかご確認ください。
投稿
-
回答の評価を上げる
以下のような回答は評価を上げましょう
- 正しい回答
- わかりやすい回答
- ためになる回答
評価が高い回答ほどページの上位に表示されます。
-
回答の評価を下げる
下記のような回答は推奨されていません。
- 間違っている回答
- 質問の回答になっていない投稿
- スパムや攻撃的な表現を用いた投稿
評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。
-2
"Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認”の行の次に、5行のコード
msgbox("シート名:" & tWs.Cells(r, 2).Value)
Set sheets = oWb.worksheets
for i=1 to sheets.count
msgbox(i & " : " & sheets[i].name)
next i
を追加して実行してみてください。
追加したコードはインデックスエラーが起きるコードで使おうとしているシート名を表示し、その後でoldPathのworkbookに含まれるworksheetの名前を順に表示するものです。(表示にmsgboxを使っていますので、何度もmsgboxが表示されます)
使おうとしているシート名のworksheetが、oWbに含まれていないからインデックスエラーが起きる訳ですから、その状況を確認するためにシート名とoWsが持っているシートの名前を確認するところから始めたら良いのではないかと思います。
投稿
-
回答の評価を上げる
以下のような回答は評価を上げましょう
- 正しい回答
- わかりやすい回答
- ためになる回答
評価が高い回答ほどページの上位に表示されます。
-
回答の評価を下げる
下記のような回答は推奨されていません。
- 間違っている回答
- 質問の回答になっていない投稿
- スパムや攻撃的な表現を用いた投稿
評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。
15分調べてもわからないことは、teratailで質問しよう!
- ただいまの回答率 88.32%
- 質問をまとめることで、思考を整理して素早く解決
- テンプレート機能で、簡単に質問をまとめられる
質問への追記・修正、ベストアンサー選択の依頼
stdio
2019/02/27 09:56
すみません、全体的に処理が重い印象を受けます。
もう少し考えて質問して頂けると幸いです。
SugiuraY
2019/02/27 10:41
申し訳ございません。。あまりvbaに明るくないため、どのようにすれば処理が軽くなるのかが速やかにはわからないため少し調べるお時間をください。
コメントお寄せいただきありがとうございます。
stdio
2019/02/27 10:47
まずどの辺で止まっているのかを教えて下さい。
ここで止まる等のコメントを入力した方が、良いアドバイスをもらえますよ。
全体的に処理に無駄が多いように見えるのが気になりますが、今回は良いとしましょう。