別のブックにシートをコピーするする際のインデックス有効範囲エラー）￥について

Question

現在ブックが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 = "ＭＳ Ｐゴシック"
    
    
    nWb.SaveAs (newPath)
    
   
    r = r + 1
  Wend
  
  
 
End Sub

Comments

[stdio]

すみません、全体的に処理が重い印象を受けます。
もう少し考えて質問して頂けると幸いです。

[SugiuraY]

申し訳ございません。。あまりvbaに明るくないため、どのようにすれば処理が軽くなるのかが速やかにはわからないため少し調べるお時間をください。
コメントお寄せいただきありがとうございます。

[stdio]

まずどの辺で止まっているのかを教えて下さい。
ここで止まる等のコメントを入力した方が、良いアドバイスをもらえますよ。
全体的に処理に無駄が多いように見えるのが気になりますが、今回は良いとしましょう。

Answer 1

アクティブ前提の作りになっているからのような気がします。
ブックをオープンした時点で、そちらのブックがアクティブになっていないでしょうか？
具体的な修正点としては、
単純にCells(r, 1)とするのではなく、シート名を指定すべきです。Worksheets("hoge").Cells(r, 1)など。
Worksheets(Cells(r, 2).Value).Activateのところも、アクティブにするのではなく、シートオブジェクトを作成すべきです。
Set sh = Worksheets(Cells(r, 2).Value)
その後、そのオブジェクトを使って、セルの参照を行います。
sh.Cells(略)
こんな感じで全体的に明示的なコードに修正してみてどうなるかご確認ください。

Comments

[SugiuraY]

コメントありがとうございます。
明示したコードに修正したのですが、オブジェクトはプロパティをサポートしていません。とのエラーが出力されました。
ちょっと
nWs.Name = tWs.Cells(r, 2).Value
の箇所がオブジェクト化したあとにシート名を変更しており、変更後のシート名を直接オブジェクトする方法が思いつかなかったため、
oWs.Copy After:=nWs(tWs.Cells(r, 2).Value)
の箇所が自信がないのですが、ここをまたワークブックやワークシートを改めて明示しなければならないのでしょうか。。

[SugiuraY]

たびたび申し訳ございません。

[ttyp03]

これでいいような気がしますが（エラーは出なくなる）、仕様的に求めている動きになるかはご確認ください。
oWs.Copy After:=nWs

[SugiuraY]

有難うございます、オブジェクト作成後加えた変更（.name）は当然にプロパティとして保持され続けるのですね、、失礼しました。
一方でループ1回目は成功し2回目のループの頭でインデックス範囲外のエラーが出力されたのですが、ループさせる場合、オブジェクトは初期化をしなければならないのでしょうか？
vba オブジェクト　初期化等であまりそれらしいものが見当たらなかったためご相談させてください。
重ねて失礼いたします。

[ttyp03]

While Cells(r, 1) <> ""
ここのCellsが曖昧になってるからでしょうか。
ここも明示的にシートを指定しないとダメですね。

[SugiuraY]

明示的に指定いたしました。
また、すでに重複しているブックがあれば開かないようにもしたりしたのですが、なぜかループしてくれません。再修正コードは上述の通りです。
実際にループにさせずにrに直接次の値を代入しても動くのですが、、、

[stdio]

tWs.Cells(r, 1) <> ""を
CStr(tWs.Cells(r, 1) .Value) <> ""
に変えてみてはいかがでしょうか？

[ttyp03]

エラーが出てる箇所が2周目の以下ですよね。
oWb.Worksheets(tWs.Cells(r, 2).Value)
rは3のはず。
つまり実行シートの3行目1列目(A3)にあるブック名の中に、3行目2列目(B3)に書かれているシートが存在しないということになります。
実行シートの値と、ブックの中身を良く見比べてみてください。
他に要因となるものは見当たりません（たぶん）

[SugiuraY]

コメントありがとうございます。
再度確認しましたが、ご指摘の箇所に意図したシート名が存在しております。
もし可能性があるとしたらループのA2とA3が同じつまり、すでに開いている同じファイルが対象になっております。ただ、事前に動かしてみたところ、すでに開いているファイルがある場合でも動作するために、 問題としなかったのですが念のために
IF tWs.Cells(r, 1)<>tWs.Cells(r,-1 1) Then
にして
もし対象のファイルを既に開いていれば
Set oWb =Workbooks(oldPath)
としましたが、それでも同じ有効範囲エラーが生じている状況です

[SugiuraY]

stdio様
コメントありがとうございます。ご指摘のコードに修正しても
同じエラーが出力されることが確認されました。

[ttyp03]

同じファイル名であっても問題は起きないような気はしますが。
試しにループ内の最後で、
oWb.Close
ってやったらどうでしょうか。

[ttyp03]

何件あるのかわかりませんが、いずれにしてもオープンしっぱなしってのはよろしくないので、パフォーマンスは落ちるかもしれませんが、クローズの処理は入れたほうがいいですね。

[SugiuraY]

コメントありがとうございます。
仰る通り、Closeを挟めば正しく動作させることができました。
対象のブックやシートを明示的に示したはずでなのに不思議な挙動なのですが、
解決に至ることができたことについて、本当に深く感謝いたします。
ただ、原因（なぜ明示している以外のブックに対して動作しているのか）は頑張って追求します。

Answer 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が持っているシートの名前を確認するところから始めたら良いのではないかと思います。

Comments

[SugiuraY]

確認方法を詳細にご教示いただきありがとうございます。
msgbox(i & " : " & sheets[i].name)
の箇所についてコンパイルエラーが生じているのですが
vbaでi番目の要素数を指定する場合にはsheets[i]で問題なのでしょうか？
恐れ入りますが、宜しくお願い申し上げます。

[coco_bauer]

Set oWb = Workbooks.Open(oldPath) の行にブレークポイントを設定して、デバッガで各オブジェクトの内容を確認してみてください。
”sheets[i]”については調べます。

[SugiuraY]

For Each i In oWb.Sheets: Debug.Print i.Name: Next i
で動作させることができました。
そこで判明したのですが、こちらで出力されるシート名はnWbのシートでした。オブジェクトの中身がなぜ書き換わってしまうのか、ちょっと調べてみます。
コメントいただきありがとうございます。