現在ブックがA.xlsmとB.xlsxがあります。
A.xlsmがマクロ実行用のエクセルです。
- A.xlsmのCells(r,1)の文字列のブックB.xlsxを開く(B.xlsxには(r,2)のシート名が存在します)
- A.xlsmのCells(r,2)の文字列の新しいブックC.xlsxを作成する
- B.xlsxのシートをC.xlsxの同じシート名にコピーする
*具体的にわかりやすく申し上げれば
A.xlsm (r,1) 天気 (r,2)20190227
B.xlsxには20190227というシートが存在しており、(1,1)に晴れと記載されている
C.xlsxに晴れというブック名を付して、B.xlsxの同じシート名の晴れという内容を
コピーしてきたい
ということになります。ループになっているの少しわかりづらいのですが
上記を意図したコードが"インデックス有効範囲エラー"がでてしまうのですが
原因と解決方法を教えてください。
宜しくお願い申し上げます。
vba
1 2Sub fileOpenAndCreate() 3 Dim fileName As String 4 Dim r As Long 5 Dim wb As Workbook 6 Dim oldPath As String 7 Dim newPath As String 8 9 r = 2 10 While Cells(r, 1) <> "" 11 oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & Cells(r, 1).Value 12 newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & Cells(r, 2).Value 13 14 Workbooks.Open (oldPath) '既にWBをOpenでも動作する仕様を確認 15 Worksheets(Cells(r, 2).Value).Activate 16 Set wb = Workbooks.Add 17 wb.SaveAs (newPath) 18 Worksheets(1).Name = Cells(r, 2).Value 19 20 Workbooks(oldPath).Worksheets(Cells(r, 1).Value).Copy After:=Workbooks(newPath).Worksheets(Cells(r, 1).Value) 21 22 23 r = r + 1 24 Wend 25 26 27 28End Sub
修正後のコード
vba
1Sub fileOpenAndCreate() 2 Dim fileName As String 3 Dim r As Long 4 Dim oldPath As String 5 Dim newPath As String 6 7 Dim nWb As Workbook 8 Dim oWb As Workbook 9 Dim oWs As Worksheet 10 Dim tWs As Worksheet 11 Dim nWs As Worksheet 12 13 14 Set tWs = Worksheets("実行シート") 15 16 r = 2 17 While Cells(r, 1) <> "" 18 oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value 19 newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value 20 21 'old------------ 22 Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認 23 Set oWs = oWb.Worksheets(tWs.Cells(r, 2).Value) 24 25 'new------------ 26 Set nWb = Workbooks.Add 27 nWb.SaveAs (newPath) 28 Set nWs = nWb.Worksheets(1) 29 nWs.Name = tWs.Cells(r, 2).Value 30 31 32 oWs.Copy After:=nWs(tWs.Cells(r, 2).Value) 33 34 35 r = r + 1 36 Wend 37 38 39 40End Sub
再修正コード
vba
1Sub fileOpenAndCreate() 2 Dim fileName As String 3 Dim r As Long 4 Dim oldPath As String 5 Dim newPath As String 6 7 Dim nWb As Workbook 8 Dim oWb As Workbook 9 Dim oWs As Worksheet 10 Dim tWs As Worksheet 11 Dim nWs As Worksheet 12 Dim nWsTf As Worksheet 13 14 15 Set tWs = Worksheets("実行シート") 16 17 r = 2 18 While tWs.Cells(r, 1) <> "" 19 20 oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value 21 newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value 22 23 24 Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認 25 Set oWs = oWb.Worksheets(tWs.Cells(r, 2).Value) 26 MsgBox "Doesnt work" & r '↑ここでインデックスエラー 27 'new------------ 28 29 30 Set nWb = Workbooks.Add 31 Set nWs = nWb.Worksheets("Sheet1") 32 oWs.Copy After:=nWs 33 34 Application.DisplayAlerts = False 35 nWs.Delete 36 Application.DisplayAlerts = True 37 38 'new tf------------ 39 Set nWsTf = nWb.Worksheets(tWs.Cells(r, 2).Value) 40 nWsTf.Cells.Font.Name = "MS Pゴシック" 41 42 43 nWb.SaveAs (newPath) 44 45 46 r = r + 1 47 Wend 48 49 50 51End Sub 52 53 54
回答2件