teratail header banner
teratail header banner
質問するログイン新規登録

質問編集履歴

3

ループエラー箇所を特定しました。

2019/02/27 03:08

投稿

SugiuraY
SugiuraY

スコア318

title CHANGED
File without changes
body CHANGED
@@ -91,4 +91,62 @@
91
91
 
92
92
 
93
93
  End Sub
94
+ ```
95
+
96
+ 再修正コード
97
+ ```vba
98
+ Sub fileOpenAndCreate()
99
+ Dim fileName As String
100
+ Dim r As Long
101
+ Dim oldPath As String
102
+ Dim newPath As String
103
+
104
+ Dim nWb As Workbook
105
+ Dim oWb As Workbook
106
+ Dim oWs As Worksheet
107
+ Dim tWs As Worksheet
108
+ Dim nWs As Worksheet
109
+ Dim nWsTf As Worksheet
110
+
111
+
112
+ Set tWs = Worksheets("実行シート")
113
+
114
+ r = 2
115
+ While tWs.Cells(r, 1) <> ""
116
+
117
+ oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
118
+ newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
119
+
120
+
121
+ Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認
122
+ Set oWs = oWb.Worksheets(tWs.Cells(r, 2).Value)
123
+ MsgBox "Doesnt work" & r '↑ここでインデックスエラー
124
+ 'new------------
125
+
126
+
127
+ Set nWb = Workbooks.Add
128
+ Set nWs = nWb.Worksheets("Sheet1")
129
+ oWs.Copy After:=nWs
130
+
131
+ Application.DisplayAlerts = False
132
+ nWs.Delete
133
+ Application.DisplayAlerts = True
134
+
135
+ 'new tf------------
136
+ Set nWsTf = nWb.Worksheets(tWs.Cells(r, 2).Value)
137
+ nWsTf.Cells.Font.Name = "MS Pゴシック"
138
+
139
+
140
+ nWb.SaveAs (newPath)
141
+
142
+
143
+ r = r + 1
144
+ Wend
145
+
146
+
147
+
148
+ End Sub
149
+
150
+
151
+
94
152
  ```

2

訂正

2019/02/27 03:08

投稿

SugiuraY
SugiuraY

スコア318

title CHANGED
File without changes
body CHANGED
@@ -68,8 +68,8 @@
68
68
 
69
69
  r = 2
70
70
  While Cells(r, 1) <> ""
71
- oldPath = "C:\Users\regawa\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
71
+ oldPath = "C:\Users\hoge\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
72
- newPath = "C:\Users\regawa\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
72
+ newPath = "C:\Users\hoge\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
73
73
 
74
74
  'old------------
75
75
  Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認

1

明示したコードに修正しました。

2019/02/27 01:34

投稿

SugiuraY
SugiuraY

スコア318

title CHANGED
File without changes
body CHANGED
@@ -46,4 +46,49 @@
46
46
 
47
47
 
48
48
  End Sub
49
+ ```
50
+
51
+
52
+ 修正後のコード
53
+ ```vba
54
+ Sub fileOpenAndCreate()
55
+ Dim fileName As String
56
+ Dim r As Long
57
+ Dim oldPath As String
58
+ Dim newPath As String
59
+
60
+ Dim nWb As Workbook
61
+ Dim oWb As Workbook
62
+ Dim oWs As Worksheet
63
+ Dim tWs As Worksheet
64
+ Dim nWs As Worksheet
65
+
66
+
67
+ Set tWs = Worksheets("実行シート")
68
+
69
+ r = 2
70
+ While Cells(r, 1) <> ""
71
+ oldPath = "C:\Users\regawa\Desktop\TEST_SSE\record\" & tWs.Cells(r, 1).Value
72
+ newPath = "C:\Users\regawa\Desktop\TEST_SSE\create\" & tWs.Cells(r, 2).Value
73
+
74
+ 'old------------
75
+ Set oWb = Workbooks.Open(oldPath) '既にWBをOpenでも動作する仕様を確認
76
+ Set oWs = oWb.Worksheets(tWs.Cells(r, 2).Value)
77
+
78
+ 'new------------
79
+ Set nWb = Workbooks.Add
80
+ nWb.SaveAs (newPath)
81
+ Set nWs = nWb.Worksheets(1)
82
+ nWs.Name = tWs.Cells(r, 2).Value
83
+
84
+
85
+ oWs.Copy After:=nWs(tWs.Cells(r, 2).Value)
86
+
87
+
88
+ r = r + 1
89
+ Wend
90
+
91
+
92
+
93
+ End Sub
49
94
  ```