teratail
回答率
85.36%
teratail header banner
teratail header banner
質問するログイン新規登録
トップに関する質問フォルダ内の全てのExcelを転記し、それぞれ名前をつけて保存するマクロをつくりました。これに、項目番号別に、それぞれ別のブックを作成する機能を追加したいです。

編集履歴

質問編集履歴

20

2021/03/02 05:14

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -22,9 +22,153 @@
22
22
 
23
23
 
24
24
 
25
+ ①項目別に作成する際に1つめのブックのみ、F10を転記し、2つ目以降については、F10の値をクリアしたいです。
26
+
27
+ もう一つ変数を組んでやろうとしましたが、上手くいきませんでした。
28
+
29
+
30
+
25
- ①コピーを保存したfnファイルを開く際に以下部分に「ReadOnly:=False」と入れているが、「読み取り専用で開きますか？」というダイアログボックスが出てきてしまう
31
+ ②不要な行を削除する文言になっているが、F〜H以外の行は、値を計算する関数が組まれているため、F〜Hの13行目以降の不要な値クリアし、F13:H13から下へ表示する仕様に変更したい
32
+
26
-
33
+ （削除すると#REFとなり計算ができなくなってしまいました。解決難しければ、再度以前作成した転記ツールで転記し直すため、こちらは必ずしも改善しなくても大丈夫です。）
34
+
27
-
35
+ '最終行が不定期な列を項目番号が一致しない場合は削除
36
+
37
+ For i = maxRow To 13 Step -1
38
+
39
+ If CStr(ws.Range("E" & CStr(i)).Value) <> CStr(k) Then ws.Rows(i).Delete
40
+
41
+
42
+
43
+
44
+
45
+ 何卒、よろしくお願いいたしますm(__)m
46
+
47
+
48
+
49
+ ```
50
+
51
+
52
+
53
+ Sub tenki()
54
+
55
+
56
+
57
+ Dim folder As String
58
+
59
+ Dim file As String
60
+
61
+ Dim book As Workbook
62
+
63
+ Dim i As Integer
64
+
65
+
66
+
67
+ '指定のフォルダを開く
68
+
69
+ With Application.FileDialog(msoFileDialogFolderPicker)
70
+
71
+ If .Show = True Then
72
+
73
+ folder = .SelectedItems(1)
74
+
75
+
76
+
77
+ End If
78
+
79
+ End With
80
+
81
+
82
+
83
+ '指定フォルダ内のすべてのフォルダに実行
84
+
85
+ file = Dir(folder & "*.xls")
86
+
87
+ Do While file <> ""
88
+
89
+
90
+
91
+ 'フォルダ内のブックを開く
92
+
93
+ Set book = Workbooks.Open(folder & "\" & file)
94
+
95
+
96
+
97
+ '必要項目を雛形ファイルへ転記
98
+
99
+ ThisWorkbook.Worksheets("計算シート").Range("F7").Value = book.Worksheets("計算シート").Range("F7").Value
100
+
101
+
102
+
103
+ ThisWorkbook.Worksheets("計算シート").Range("G7").Value = book.Worksheets("計算シート").Range("G7").Value
104
+
105
+
106
+
107
+ ThisWorkbook.Worksheets("計算シート").Range("I7").Value = book.Worksheets("計算シート").Range("I7").Value
108
+
109
+
110
+
111
+ ThisWorkbook.Worksheets("計算シート").Range("O7").Value = book.Worksheets("計算シート").Range("O7").Value
112
+
113
+
114
+
115
+ ThisWorkbook.Worksheets("計算シート").Range("F10").Value = book.Worksheets("計算シート").Range("F10").Value
116
+
117
+
118
+
119
+ '必要項目のうち、最終行が不定期な列を最終行まで転記
120
+
121
+ Dim moto As Worksheet
122
+
123
+ Dim saki As Worksheet
124
+
125
+ Dim maxRow
126
+
127
+
128
+
129
+ Set moto = book.Worksheets("計算シート")
130
+
131
+ Set saki = ThisWorkbook.Worksheets("計算シート")
132
+
133
+ maxRow = moto.Cells(Rows.Count, 1).End(xlUp).Row
134
+
135
+ Dim dic, k
136
+
137
+ Set dic = CreateObject("Scripting.Dictionary")
138
+
139
+
140
+
141
+ For i = 13 To maxRow
142
+
143
+
144
+
145
+ saki.Range("F" & CStr(i)).Value = moto.Range("F" & CStr(i)).Value
146
+
147
+ saki.Range("G" & CStr(i)).Value = moto.Range("G" & CStr(i)).Value
148
+
149
+ saki.Range("H" & CStr(i)).Value = moto.Range("H" & CStr(i)).Value
150
+
151
+ saki.Range("I" & CStr(i)).Value = moto.Range("I" & CStr(i)).Value
152
+
153
+
154
+
155
+ k = saki.Range("E" & CStr(i)).Value
156
+
157
+ dic(k) = "C:計算ツール格納フォルダ/計算ツール_" & Format(ThisWorkbook.Worksheets("変更前検証").Range("F7")) & "_" & Format(k) & ".xls"
158
+
159
+
160
+
161
+ Next
162
+
163
+
164
+
165
+ Dim fn As String
166
+
167
+ Dim wb As Workbook
168
+
169
+ Dim ws As Worksheet
170
+
171
+
28
172
 
29
173
  For Each k In dic
30
174
 
@@ -40,256 +184,84 @@
40
184
 
41
185
 
42
186
 
43
- ②不要な行を削除後、再度fnファイルを保存するときに「〜という名前のファイルが既にあります。置き換えますか？」というダイアログボックスがでてきてしまう
44
-
45
-
46
-
47
- ③2つ目のファイルの転記に入ると、①が自動で読取専用で開かれるため、マクロが「このファイルは読み取り専用です。その名前で保存することはできません。」というエラーでとまってしまう。
48
-
49
-
50
-
51
- ④項目別に作成する際に1つめのブックのみ、F10を転記し、2つ目以降については、F10の値をクリアしたいです。
52
-
53
- もう一つ変数を組んでやろうとしましたが、上手くいきませんでした。
54
-
55
-
56
-
57
- できれば、
58
-
59
- ⑤不要な行を削除する文言になっているが、F〜H以外の行は、値を計算する関数が組まれているため、F〜Hの13行目以降の不要な値クリアし、F13:H13から下へ表示する仕様に変更したい
60
-
61
- （削除すると#REFとなり計算ができなくなってしまいました。解決難しければ、再度以前作成した転記ツールで転記し直すため、こちらは必ずしも改善しなくても大丈夫です。）
62
-
63
187
  '最終行が不定期な列を項目番号が一致しない場合は削除
64
188
 
65
189
  For i = maxRow To 13 Step -1
66
190
 
67
191
  If CStr(ws.Range("E" & CStr(i)).Value) <> CStr(k) Then ws.Rows(i).Delete
68
192
 
193
+
194
+
69
-
195
+ Next
196
+
197
+
198
+
70
-
199
+ '不要な列を削除した計算ツールを名前を付けて保存
200
+
71
-
201
+ wb.SaveAs fn
202
+
72
-
203
+ wb.Close
204
+
205
+
206
+
207
+ Next
208
+
209
+
210
+
211
+
212
+
73
- 何卒、よろしくお願いいたしますm(__)m
213
+ Dim Filename As String
214
+
215
+
216
+
74
-
217
+ Filename = "C:計算ツール格納フォルダ/計算ツール_" & Format(ThisWorkbook.Worksheets("変更前検証").Range("F7")) & "_" & Format(k) & ".xls"
218
+
219
+
220
+
75
-
221
+ ThisWorkbook.SaveCopyAs Filename
222
+
223
+ Application.DisplayAlerts = False
224
+
225
+
226
+
227
+ file = Dir()
228
+
229
+
230
+
231
+ '転記対象のファイルを閉じる
232
+
233
+ book.Close SaveChanges:=False
234
+
235
+ Application.DisplayAlerts = False
236
+
237
+
238
+
239
+ '雛形ファイルに転記したデータを削除
240
+
241
+ ThisWorkbook.Worksheets("計算シート").Range("F7").ClearContents
242
+
243
+ ThisWorkbook.Worksheets("計算シート").Range("G7").ClearContents
244
+
245
+ ThisWorkbook.Worksheets("計算シート").Range("I7").ClearContents
246
+
247
+ ThisWorkbook.Worksheets("計算シート").Range("O7").ClearContents
248
+
249
+ ThisWorkbook.Worksheets("計算シート").Range("F10").ClearContents
250
+
251
+ ThisWorkbook.Worksheets("計算シート").Range("F13:I200").ClearContents
252
+
253
+
254
+
255
+
256
+
257
+ Loop
258
+
259
+
260
+
261
+
262
+
263
+ End Sub
264
+
265
+
76
266
 
77
267
  ```
78
-
79
-
80
-
81
- Sub tenki()
82
-
83
-
84
-
85
- Dim folder As String
86
-
87
- Dim file As String
88
-
89
- Dim book As Workbook
90
-
91
- Dim i As Integer
92
-
93
-
94
-
95
- '指定のフォルダを開く
96
-
97
- With Application.FileDialog(msoFileDialogFolderPicker)
98
-
99
- If .Show = True Then
100
-
101
- folder = .SelectedItems(1)
102
-
103
-
104
-
105
- End If
106
-
107
- End With
108
-
109
-
110
-
111
- '指定フォルダ内のすべてのフォルダに実行
112
-
113
- file = Dir(folder & "*.xls")
114
-
115
- Do While file <> ""
116
-
117
-
118
-
119
- 'フォルダ内のブックを開く
120
-
121
- Set book = Workbooks.Open(folder & "\" & file)
122
-
123
-
124
-
125
- '必要項目を雛形ファイルへ転記
126
-
127
- ThisWorkbook.Worksheets("計算シート").Range("F7").Value = book.Worksheets("計算シート").Range("F7").Value
128
-
129
-
130
-
131
- ThisWorkbook.Worksheets("計算シート").Range("G7").Value = book.Worksheets("計算シート").Range("G7").Value
132
-
133
-
134
-
135
- ThisWorkbook.Worksheets("計算シート").Range("I7").Value = book.Worksheets("計算シート").Range("I7").Value
136
-
137
-
138
-
139
- ThisWorkbook.Worksheets("計算シート").Range("O7").Value = book.Worksheets("計算シート").Range("O7").Value
140
-
141
-
142
-
143
- ThisWorkbook.Worksheets("計算シート").Range("F10").Value = book.Worksheets("計算シート").Range("F10").Value
144
-
145
-
146
-
147
- '必要項目のうち、最終行が不定期な列を最終行まで転記
148
-
149
- Dim moto As Worksheet
150
-
151
- Dim saki As Worksheet
152
-
153
- Dim maxRow
154
-
155
-
156
-
157
- Set moto = book.Worksheets("計算シート")
158
-
159
- Set saki = ThisWorkbook.Worksheets("計算シート")
160
-
161
- maxRow = moto.Cells(Rows.Count, 1).End(xlUp).Row
162
-
163
- Dim dic, k
164
-
165
- Set dic = CreateObject("Scripting.Dictionary")
166
-
167
-
168
-
169
- For i = 13 To maxRow
170
-
171
-
172
-
173
- saki.Range("F" & CStr(i)).Value = moto.Range("F" & CStr(i)).Value
174
-
175
- saki.Range("G" & CStr(i)).Value = moto.Range("G" & CStr(i)).Value
176
-
177
- saki.Range("H" & CStr(i)).Value = moto.Range("H" & CStr(i)).Value
178
-
179
- saki.Range("I" & CStr(i)).Value = moto.Range("I" & CStr(i)).Value
180
-
181
-
182
-
183
- k = saki.Range("E" & CStr(i)).Value
184
-
185
- dic(k) = "C:計算ツール格納フォルダ/計算ツール_" & Format(ThisWorkbook.Worksheets("変更前検証").Range("F7")) & "_" & Format(k) & ".xls"
186
-
187
-
188
-
189
- Next
190
-
191
-
192
-
193
- Dim fn As String
194
-
195
- Dim wb As Workbook
196
-
197
- Dim ws As Worksheet
198
-
199
-
200
-
201
- For Each k In dic
202
-
203
- fn = dic(k)
204
-
205
- ThisWorkbook.SaveCopyAs fn
206
-
207
-
208
-
209
- Set wb = Workbooks.Open(fn, ReadOnly:=False)
210
-
211
- Set ws = wb.Worksheets("計算シート")
212
-
213
-
214
-
215
- '最終行が不定期な列を項目番号が一致しない場合は削除
216
-
217
- For i = maxRow To 13 Step -1
218
-
219
- If CStr(ws.Range("E" & CStr(i)).Value) <> CStr(k) Then ws.Rows(i).Delete
220
-
221
-
222
-
223
- Next
224
-
225
-
226
-
227
- '不要な列を削除した計算ツールを名前を付けて保存
228
-
229
- wb.SaveAs fn
230
-
231
- wb.Close
232
-
233
-
234
-
235
- Next
236
-
237
-
238
-
239
-
240
-
241
- Dim Filename As String
242
-
243
-
244
-
245
- Filename = "C:計算ツール格納フォルダ/計算ツール_" & Format(ThisWorkbook.Worksheets("変更前検証").Range("F7")) & "_" & Format(k) & ".xls"
246
-
247
-
248
-
249
- ThisWorkbook.SaveCopyAs Filename
250
-
251
- Application.DisplayAlerts = False
252
-
253
-
254
-
255
- file = Dir()
256
-
257
-
258
-
259
- '転記対象のファイルを閉じる
260
-
261
- book.Close SaveChanges:=False
262
-
263
- Application.DisplayAlerts = False
264
-
265
-
266
-
267
- '雛形ファイルに転記したデータを削除
268
-
269
- ThisWorkbook.Worksheets("計算シート").Range("F7").ClearContents
270
-
271
- ThisWorkbook.Worksheets("計算シート").Range("G7").ClearContents
272
-
273
- ThisWorkbook.Worksheets("計算シート").Range("I7").ClearContents
274
-
275
- ThisWorkbook.Worksheets("計算シート").Range("O7").ClearContents
276
-
277
- ThisWorkbook.Worksheets("計算シート").Range("F10").ClearContents
278
-
279
- ThisWorkbook.Worksheets("計算シート").Range("F13:I200").ClearContents
280
-
281
-
282
-
283
-
284
-
285
- Loop
286
-
287
-
288
-
289
-
290
-
291
- End Sub
292
-
293
-
294
-
295
- ```

19

2021/03/02 05:14

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -44,7 +44,19 @@
44
44
 
45
45
 
46
46
 
47
+ ③2つ目のファイルの転記に入ると、①が自動で読取専用で開かれるため、マクロが「このファイルは読み取り専用です。その名前で保存することはできません。」というエラーでとまってしまう。
48
+
49
+
50
+
51
+ ④項目別に作成する際に1つめのブックのみ、F10を転記し、2つ目以降については、F10の値をクリアしたいです。
52
+
53
+ もう一つ変数を組んでやろうとしましたが、上手くいきませんでした。
54
+
55
+
56
+
57
+ できれば、
58
+
47
- ③不要な行を削除する文言になっているが、F〜H以外の行は、値を計算する関数が組まれているため、F〜Hの13行目以降の不要な値クリアし、F13:H13から下へ表示する仕様に変更したい
59
+ ⑤不要な行を削除する文言になっているが、F〜H以外の行は、値を計算する関数が組まれているため、F〜Hの13行目以降の不要な値クリアし、F13:H13から下へ表示する仕様に変更したい
48
60
 
49
61
  （削除すると#REFとなり計算ができなくなってしまいました。解決難しければ、再度以前作成した転記ツールで転記し直すため、こちらは必ずしも改善しなくても大丈夫です。）
50
62
 
@@ -56,8 +68,6 @@
56
68
 
57
69
 
58
70
 
59
- ④2つ目のファイルの転記に入ると、①が自動で読取専用で開かれるため、マクロが「このファイルは読み取り専用です。その名前で保存することはできません。」というエラーでとまってしまう。
60
-
61
71
 
62
72
 
63
73
  何卒、よろしくお願いいたしますm(__)m

18

2021/03/02 04:55

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -2,13 +2,11 @@
2
2
 
3
3
 
4
4
 
5
-
6
-
7
- フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)をExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、フォルダ内の次のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
5
+ フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)をExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、フォルダ内の次のExcelファイルの必要項目を転記、、というループ処理をするマクロを組んでいます。
8
-
9
-
10
-
6
+
7
+
8
+
11
- 転記したExcelには、E列に関数を組んでおり、転記結果をもとに転記した行を項目番号1,2,3....に分類できる仕様にしました。
9
+ 転記したExcelには、E列に関数を組んでおり、転記結果をもとに行を項目番号1,2,3....に分類できる仕様にしました。
12
10
 
13
11
  項目番号が複数ある場合は、項目番号毎に、それぞれExcelファイル（雛形）に転記し名前をつけて保存するという条件分岐をつけたいです。
14
12
 

17

2021/03/02 04:45

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -216,6 +216,8 @@
216
216
 
217
217
 
218
218
 
219
+ '不要な列を削除した計算ツールを名前を付けて保存
220
+
219
221
  wb.SaveAs fn
220
222
 
221
223
  wb.Close
@@ -226,7 +228,7 @@
226
228
 
227
229
 
228
230
 
229
- '不要な列を削除した計算ツールを名前を付けて保存
231
+
230
232
 
231
233
  Dim Filename As String
232
234
 

16

2021/03/02 04:43

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -46,9 +46,9 @@
46
46
 
47
47
 
48
48
 
49
- ③不要な行を削除する文言になっているが、F〜H以外の行は、値を計算する関数が組まれているため、F〜Hの13行目以降の不要な部分を削除する仕様に変更したい
49
+ ③不要な行を削除する文言になっているが、F〜H以外の行は、値を計算する関数が組まれているため、F〜Hの13行目以降の不要な値クリアし、F13:H13から下へ表示する仕様に変更したい
50
+
50
-
51
+ （削除すると#REFとなり計算ができなくなってしまいました。解決難しければ、再度以前作成した転記ツールで転記し直すため、こちらは必ずしも改善しなくても大丈夫です。）
51
-
52
52
 
53
53
  '最終行が不定期な列を項目番号が一致しない場合は削除
54
54
 

15

2021/03/02 04:02

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -24,7 +24,7 @@
24
24
 
25
25
 
26
26
 
27
- ①コピーを保存したfnのフォルダを開く際に以下部分に「ReadOnly:=False」と入れているが、「読み取り専用で開きますか？」というダイアログボックスが出てきてしまう
27
+ ①コピーを保存したfnファイルを開く際に以下部分に「ReadOnly:=False」と入れているが、「読み取り専用で開きますか？」というダイアログボックスが出てきてしまう
28
28
 
29
29
 
30
30
 

14

2021/03/02 03:42

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -14,171 +14,271 @@
14
14
 
15
15
 
16
16
 
17
+ 回答者様にご教示いただいた内容を反映させました。
18
+
17
- 色々ネットで検索し、フィルターをかける方法や不要なものを削除する方法など出てきたため試しましたが、組み合わせ方が悪いようでうまく行きませんでした。
19
+ 何日も色々直し続けても分からず、困っていたため本当にありがとうございます。
18
-
19
-
20
-
20
+
21
+
22
+
21
- どこにどのような文言を追加すればいいか、教えていただけるとありがたいです。
23
+ 追加で以下の点について改善したく、お力添えいただきたいです。
24
+
25
+
26
+
22
-
27
+ ①コピーを保存したfnのフォルダを開く際に以下部分に「ReadOnly:=False」と入れているが、「読み取り専用で開きますか？」というダイアログボックスが出てきてしまう
28
+
29
+
30
+
23
-
31
+ For Each k In dic
32
+
24
-
33
+ fn = dic(k)
34
+
35
+ ThisWorkbook.SaveCopyAs fn
36
+
37
+
38
+
39
+ Set wb = Workbooks.Open(fn, ReadOnly:=False)
40
+
41
+ Set ws = wb.Worksheets("計算シート")
42
+
43
+
44
+
45
+ ②不要な行を削除後、再度fnファイルを保存するときに「〜という名前のファイルが既にあります。置き換えますか？」というダイアログボックスがでてきてしまう
46
+
47
+
48
+
25
- ※なお、下記マクロで雛形へ全件転記後に、別のマクロを新しいExcelで組んで、項目番号毎に転記するのでも良いです。
49
+ ③不要な行を削除する文言になっているが、F〜H以外の行は、値を計算する関数が組まれているため、F〜Hの13行目以降の不要な部分を削除する仕様に変更したい
50
+
51
+
52
+
26
-
53
+ '最終行が不定期な列を項目番号が一致しない場合は削除
54
+
27
-
55
+ For i = maxRow To 13 Step -1
56
+
57
+ If CStr(ws.Range("E" & CStr(i)).Value) <> CStr(k) Then ws.Rows(i).Delete
58
+
59
+
60
+
61
+ ④2つ目のファイルの転記に入ると、①が自動で読取専用で開かれるため、マクロが「このファイルは読み取り専用です。その名前で保存することはできません。」というエラーでとまってしまう。
62
+
63
+
64
+
65
+ 何卒、よろしくお願いいたしますm(__)m
28
66
 
29
67
 
30
68
 
31
69
  ```
32
70
 
33
-
34
-
35
- Sub tenki()
36
-
37
-
38
-
39
- Dim folder As String
40
-
41
- Dim file As String
42
-
43
- Dim book As Workbook
44
-
45
- Dim i As Integer
46
-
47
-
48
-
49
- '転記するフォルダを選択
50
-
51
- With Application.FileDialog(msoFileDialogFolderPicker)
52
-
53
-
54
-
55
- If .Show = True Then
56
-
57
-
58
-
59
- folder = .SelectedItems(1)
60
-
61
-
62
-
63
- End If
64
-
65
- End With
66
-
67
-
68
-
69
- ’フォルダ内のファイルを全て転記
70
-
71
- file = Dir(folder & "*.xls")
72
-
73
- Do While file <> ""
74
-
75
-
76
-
77
- ’転記対象のファイルをbookと定義
78
-
79
- Set book = Workbooks.Open(folder & "\" & file)
80
-
81
-
82
-
83
- ’必要項目を転記
84
-
85
- ThisWorkbook.Worksheets("sheet1").Range("F7").Value = book.Worksheets("sheet1").Range("F7").Value
86
-
87
-
88
-
89
- ThisWorkbook.Worksheets("sheet1").Range("G7").Value = book.Worksheets("sheet1").Range("G7").Value
90
-
91
-
92
-
93
- ThisWorkbook.Worksheets("sheet1").Range("I7").Value = book.Worksheets("sheet1").Range("I7").Value
94
-
95
-
96
-
97
- ThisWorkbook.Worksheets("sheet1").Range("O7").Value = book.Worksheets("sheet1").Range("O7").Value
98
-
99
-
100
-
101
- ThisWorkbook.Worksheets("sheet1").Range("F10").Value = book.Worksheets("sheet1").Range("F10").Value
102
-
103
-
104
-
105
- ’必要項目のうち、最終行が不定期な列を最終行まで転記
106
-
107
- For i = 13 To book.Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
108
-
109
-
110
-
111
- ThisWorkbook.Worksheets("sheet1").Range("F" & CStr(i)).Value = book.Worksheets("sheet1").Range("F" & CStr(i)).Value
112
-
113
-
114
-
115
- ThisWorkbook.Worksheets("sheet1").Range("G" & CStr(i)).Value = book.Worksheets("sheet1").Range("G" & CStr(i)).Value
116
-
117
-
118
-
119
- ThisWorkbook.Worksheets("sheet1").Range("H" & CStr(i)).Value = book.Worksheets("sheet1").Range("H" & CStr(i)).Value
120
-
121
-
122
-
123
- ThisWorkbook.Worksheets("sheet1").Range("I" & CStr(i)).Value = book.Worksheets("sheet1").Range("I" & CStr(i)).Value
124
-
125
-
126
-
127
- Next
128
-
129
-
130
-
131
- ’転記完了後の雛形ファイルを名前を付けてコピーを保存
132
-
133
- Dim Filename As String
134
-
135
-
136
-
137
- Filename = "C:計算ツール格納フォルダ/算ツール_" & Format(ThisWorkbook.Worksheets("sheet1").Range("F7")) & ".xls"
138
-
139
-
140
-
141
- ThisWorkbook.SaveCopyAs Filename
142
-
143
- Application.DisplayAlerts = False
144
-
145
-
146
-
147
- file = Dir()
148
-
149
-
150
-
151
- ’転記対象ファイルを閉じる
152
-
153
- book.Close SaveChanges:=False
154
-
155
- Application.DisplayAlerts = False
156
-
157
-
158
-
159
- ’雛形ファイルに転記したデータを削除
160
-
161
- ThisWorkbook.Worksheets("sheet1").Range("F7").ClearContents
162
-
163
- ThisWorkbook.Worksheets("sheet1").Range("G7").ClearContents
164
-
165
- ThisWorkbook.Worksheets("sheet1").Range("I7").ClearContents
166
-
167
- ThisWorkbook.Worksheets("sheet1").Range("O7").ClearContents
168
-
169
- ThisWorkbook.Worksheets("sheet1").Range("F10").ClearContents
170
-
171
- ThisWorkbook.Worksheets("sheet1").Range("F13:I200").ClearContents
172
-
173
-
174
-
175
- Loop
176
-
177
-
178
-
179
-
180
-
181
- End Sub
71
+
72
+
73
+ Sub tenki()
74
+
75
+
76
+
77
+ Dim folder As String
78
+
79
+ Dim file As String
80
+
81
+ Dim book As Workbook
82
+
83
+ Dim i As Integer
84
+
85
+
86
+
87
+ '指定のフォルダを開く
88
+
89
+ With Application.FileDialog(msoFileDialogFolderPicker)
90
+
91
+ If .Show = True Then
92
+
93
+ folder = .SelectedItems(1)
94
+
95
+
96
+
97
+ End If
98
+
99
+ End With
100
+
101
+
102
+
103
+ '指定フォルダ内のすべてのフォルダに実行
104
+
105
+ file = Dir(folder & "*.xls")
106
+
107
+ Do While file <> ""
108
+
109
+
110
+
111
+ 'フォルダ内のブックを開く
112
+
113
+ Set book = Workbooks.Open(folder & "\" & file)
114
+
115
+
116
+
117
+ '必要項目を雛形ファイルへ転記
118
+
119
+ ThisWorkbook.Worksheets("計算シート").Range("F7").Value = book.Worksheets("計算シート").Range("F7").Value
120
+
121
+
122
+
123
+ ThisWorkbook.Worksheets("計算シート").Range("G7").Value = book.Worksheets("計算シート").Range("G7").Value
124
+
125
+
126
+
127
+ ThisWorkbook.Worksheets("計算シート").Range("I7").Value = book.Worksheets("計算シート").Range("I7").Value
128
+
129
+
130
+
131
+ ThisWorkbook.Worksheets("計算シート").Range("O7").Value = book.Worksheets("計算シート").Range("O7").Value
132
+
133
+
134
+
135
+ ThisWorkbook.Worksheets("計算シート").Range("F10").Value = book.Worksheets("計算シート").Range("F10").Value
136
+
137
+
138
+
139
+ '必要項目のうち、最終行が不定期な列を最終行まで転記
140
+
141
+ Dim moto As Worksheet
142
+
143
+ Dim saki As Worksheet
144
+
145
+ Dim maxRow
146
+
147
+
148
+
149
+ Set moto = book.Worksheets("計算シート")
150
+
151
+ Set saki = ThisWorkbook.Worksheets("計算シート")
152
+
153
+ maxRow = moto.Cells(Rows.Count, 1).End(xlUp).Row
154
+
155
+ Dim dic, k
156
+
157
+ Set dic = CreateObject("Scripting.Dictionary")
158
+
159
+
160
+
161
+ For i = 13 To maxRow
162
+
163
+
164
+
165
+ saki.Range("F" & CStr(i)).Value = moto.Range("F" & CStr(i)).Value
166
+
167
+ saki.Range("G" & CStr(i)).Value = moto.Range("G" & CStr(i)).Value
168
+
169
+ saki.Range("H" & CStr(i)).Value = moto.Range("H" & CStr(i)).Value
170
+
171
+ saki.Range("I" & CStr(i)).Value = moto.Range("I" & CStr(i)).Value
172
+
173
+
174
+
175
+ k = saki.Range("E" & CStr(i)).Value
176
+
177
+ dic(k) = "C:計算ツール格納フォルダ/計算ツール_" & Format(ThisWorkbook.Worksheets("変更前検証").Range("F7")) & "_" & Format(k) & ".xls"
178
+
179
+
180
+
181
+ Next
182
+
183
+
184
+
185
+ Dim fn As String
186
+
187
+ Dim wb As Workbook
188
+
189
+ Dim ws As Worksheet
190
+
191
+
192
+
193
+ For Each k In dic
194
+
195
+ fn = dic(k)
196
+
197
+ ThisWorkbook.SaveCopyAs fn
198
+
199
+
200
+
201
+ Set wb = Workbooks.Open(fn, ReadOnly:=False)
202
+
203
+ Set ws = wb.Worksheets("計算シート")
204
+
205
+
206
+
207
+ '最終行が不定期な列を項目番号が一致しない場合は削除
208
+
209
+ For i = maxRow To 13 Step -1
210
+
211
+ If CStr(ws.Range("E" & CStr(i)).Value) <> CStr(k) Then ws.Rows(i).Delete
212
+
213
+
214
+
215
+ Next
216
+
217
+
218
+
219
+ wb.SaveAs fn
220
+
221
+ wb.Close
222
+
223
+
224
+
225
+ Next
226
+
227
+
228
+
229
+ '不要な列を削除した計算ツールを名前を付けて保存
230
+
231
+ Dim Filename As String
232
+
233
+
234
+
235
+ Filename = "C:計算ツール格納フォルダ/計算ツール_" & Format(ThisWorkbook.Worksheets("変更前検証").Range("F7")) & "_" & Format(k) & ".xls"
236
+
237
+
238
+
239
+ ThisWorkbook.SaveCopyAs Filename
240
+
241
+ Application.DisplayAlerts = False
242
+
243
+
244
+
245
+ file = Dir()
246
+
247
+
248
+
249
+ '転記対象のファイルを閉じる
250
+
251
+ book.Close SaveChanges:=False
252
+
253
+ Application.DisplayAlerts = False
254
+
255
+
256
+
257
+ '雛形ファイルに転記したデータを削除
258
+
259
+ ThisWorkbook.Worksheets("計算シート").Range("F7").ClearContents
260
+
261
+ ThisWorkbook.Worksheets("計算シート").Range("G7").ClearContents
262
+
263
+ ThisWorkbook.Worksheets("計算シート").Range("I7").ClearContents
264
+
265
+ ThisWorkbook.Worksheets("計算シート").Range("O7").ClearContents
266
+
267
+ ThisWorkbook.Worksheets("計算シート").Range("F10").ClearContents
268
+
269
+ ThisWorkbook.Worksheets("計算シート").Range("F13:I200").ClearContents
270
+
271
+
272
+
273
+
274
+
275
+ Loop
276
+
277
+
278
+
279
+
280
+
281
+ End Sub
182
282
 
183
283
 
184
284
 

13

2021/03/02 03:36

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -8,7 +8,7 @@
8
8
 
9
9
 
10
10
 
11
- 転記したExcelには、E列に関数を組んでおり、転記結果をもとに転記した行を項目番号0,1,2,3....に分類できる仕様にしました。
11
+ 転記したExcelには、E列に関数を組んでおり、転記結果をもとに転記した行を項目番号1,2,3....に分類できる仕様にしました。
12
12
 
13
13
  項目番号が複数ある場合は、項目番号毎に、それぞれExcelファイル（雛形）に転記し名前をつけて保存するという条件分岐をつけたいです。
14
14
 

12

2021/03/01 09:44

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -1,4 +1,6 @@
1
1
  既に作成済みのマクロに機能を追加したいです。
2
+
3
+
2
4
 
3
5
 
4
6
 

11

2021/03/01 07:06

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -4,11 +4,11 @@
4
4
 
5
5
  フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)をExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、フォルダ内の次のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
6
6
 
7
+
8
+
7
9
  転記したExcelには、E列に関数を組んでおり、転記結果をもとに転記した行を項目番号0,1,2,3....に分類できる仕様にしました。
8
10
 
9
- 項目番号が複数ある場合は、項目番号毎に、それぞれExcelファイル（雛形）に転記し名前をつけて保存する
11
+ 項目番号が複数ある場合は、項目番号毎に、それぞれExcelファイル（雛形）に転記し名前をつけて保存するという条件分岐をつけたいです。
10
-
11
- という条件分岐をつけたいです。
12
12
 
13
13
 
14
14
 

10

2021/02/26 15:37

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -17,6 +17,12 @@
17
17
 
18
18
 
19
19
  どこにどのような文言を追加すればいいか、教えていただけるとありがたいです。
20
+
21
+
22
+
23
+ ※なお、下記マクロで雛形へ全件転記後に、別のマクロを新しいExcelで組んで、項目番号毎に転記するのでも良いです。
24
+
25
+
20
26
 
21
27
 
22
28
 

9

2021/02/25 09:25

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -58,7 +58,7 @@
58
58
 
59
59
 
60
60
 
61
- ’フォルダ内のファイルを全てコピー
61
+ ’フォルダ内のファイルを全て転記
62
62
 
63
63
  file = Dir(folder & "*.xls")
64
64
 
@@ -120,7 +120,7 @@
120
120
 
121
121
 
122
122
 
123
- ’転記完了後のこの雛形ファイルを名前を付けてコピーを保存
123
+ ’転記完了後の雛形ファイルを名前を付けてコピーを保存
124
124
 
125
125
  Dim Filename As String
126
126
 
@@ -140,7 +140,7 @@
140
140
 
141
141
 
142
142
 
143
- ’転記対象フォルダを閉じる
143
+ ’転記対象ファイルを閉じる
144
144
 
145
145
  book.Close SaveChanges:=False
146
146
 

8

2021/02/25 09:19

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -2,11 +2,11 @@
2
2
 
3
3
 
4
4
 
5
- マクロで、フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)を下記記載のマクロが組まれたExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、フォルダ内の次のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
5
+ フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)をExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、フォルダ内の次のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
6
6
 
7
7
  転記したExcelには、E列に関数を組んでおり、転記結果をもとに転記した行を項目番号0,1,2,3....に分類できる仕様にしました。
8
8
 
9
- この項目番号毎にそれぞれ新しい雛形に転記し名前をつけて保存する
9
+ 項目番号が複数ある場合は、項目番号毎に、それぞれExcelファイル（雛形）に転記し名前をつけて保存する
10
10
 
11
11
  という条件分岐をつけたいです。
12
12
 

7

2021/02/25 09:17

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -19,6 +19,10 @@
19
19
  どこにどのような文言を追加すればいいか、教えていただけるとありがたいです。
20
20
 
21
21
 
22
+
23
+ ```
24
+
25
+
22
26
 
23
27
  Sub tenki()
24
28
 
@@ -167,3 +171,7 @@
167
171
 
168
172
 
169
173
  End Sub
174
+
175
+
176
+
177
+ ```

6

2021/02/25 09:12

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -2,7 +2,7 @@
2
2
 
3
3
 
4
4
 
5
- マクロで、フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)を下記記載のマクロが組まれたExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、次のフォルダ内のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
5
+ マクロで、フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)を下記記載のマクロが組まれたExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、フォルダ内の次のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
6
6
 
7
7
  転記したExcelには、E列に関数を組んでおり、転記結果をもとに転記した行を項目番号0,1,2,3....に分類できる仕様にしました。
8
8
 

5

2021/02/25 08:31

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -2,9 +2,7 @@
2
2
 
3
3
 
4
4
 
5
- マクロで、フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)を下記記載のマクロが組まれたExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリ
5
+ マクロで、フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)を下記記載のマクロが組まれたExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリアし、次のフォルダ内のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
6
-
7
- アし、次のフォルダ内のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
8
6
 
9
7
  転記したExcelには、E列に関数を組んでおり、転記結果をもとに転記した行を項目番号0,1,2,3....に分類できる仕様にしました。
10
8
 

4

2021/02/25 08:31

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -2,7 +2,7 @@
2
2
 
3
3
 
4
4
 
5
- マクロで、フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)を下記記載のマクロが組まれたExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル②のデータをクリ
5
+ マクロで、フォルダ内にあるExcelファイル（数千個）の必要項目(ファイルによってどの行までデータがあるか異なる)を下記記載のマクロが組まれたExcelファイル(雛形)へ転記し、名前をつけてコピーを保存。その後Excelファイル（雛形）のデータをクリ
6
6
 
7
7
  アし、次のフォルダ内のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
8
8
 

3

2021/02/25 08:30

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -20,11 +20,7 @@
20
20
 
21
21
  どこにどのような文言を追加すればいいか、教えていただけるとありがたいです。
22
22
 
23
-
24
-
25
-
26
-
27
-
23
+
28
24
 
29
25
  Sub tenki()
30
26
 
@@ -40,11 +36,15 @@
40
36
 
41
37
 
42
38
 
39
+ '転記するフォルダを選択
40
+
43
41
  With Application.FileDialog(msoFileDialogFolderPicker)
44
42
 
45
43
 
46
44
 
47
45
  If .Show = True Then
46
+
47
+
48
48
 
49
49
  folder = .SelectedItems(1)
50
50
 
@@ -56,17 +56,21 @@
56
56
 
57
57
 
58
58
 
59
+ ’フォルダ内のファイルを全てコピー
60
+
59
61
  file = Dir(folder & "*.xls")
60
-
61
-
62
62
 
63
63
  Do While file <> ""
64
64
 
65
65
 
66
66
 
67
+ ’転記対象のファイルをbookと定義
68
+
67
69
  Set book = Workbooks.Open(folder & "\" & file)
68
70
 
69
71
 
72
+
73
+ ’必要項目を転記
70
74
 
71
75
  ThisWorkbook.Worksheets("sheet1").Range("F7").Value = book.Worksheets("sheet1").Range("F7").Value
72
76
 
@@ -87,6 +91,8 @@
87
91
  ThisWorkbook.Worksheets("sheet1").Range("F10").Value = book.Worksheets("sheet1").Range("F10").Value
88
92
 
89
93
 
94
+
95
+ ’必要項目のうち、最終行が不定期な列を最終行まで転記
90
96
 
91
97
  For i = 13 To book.Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
92
98
 
@@ -112,7 +118,11 @@
112
118
 
113
119
 
114
120
 
121
+ ’転記完了後のこの雛形ファイルを名前を付けてコピーを保存
122
+
115
123
  Dim Filename As String
124
+
125
+
116
126
 
117
127
  Filename = "C:計算ツール格納フォルダ/算ツール_" & Format(ThisWorkbook.Worksheets("sheet1").Range("F7")) & ".xls"
118
128
 
@@ -128,11 +138,15 @@
128
138
 
129
139
 
130
140
 
141
+ ’転記対象フォルダを閉じる
142
+
131
143
  book.Close SaveChanges:=False
132
144
 
133
145
  Application.DisplayAlerts = False
134
146
 
135
147
 
148
+
149
+ ’雛形ファイルに転記したデータを削除
136
150
 
137
151
  ThisWorkbook.Worksheets("sheet1").Range("F7").ClearContents
138
152
 
@@ -148,8 +162,6 @@
148
162
 
149
163
 
150
164
 
151
-
152
-
153
165
  Loop
154
166
 
155
167
 

2

2021/02/25 07:56

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
File without changes
test CHANGED
@@ -6,15 +6,9 @@
6
6
 
7
7
  アし、次のフォルダ内のExcelファイルの必要項目を転記、、、というループ処理をするマクロを組んでいます。
8
8
 
9
- このマクロの下記部分に
9
+ 転記したExcelには、E列に関数を組んでおり、転記結果をもとに転記した行を項目番号0,1,2,3....に分類できる仕様にしました。
10
10
 
11
-
12
-
13
- ThisWorkbook.Worksheets("sheet1").Range("F" & CStr(i)).Value = book.Worksheets("sheet1").Range("F" & CStr(i)).Value
14
-
15
-
16
-
17
- F列に入力されている項目番号0,1,2,3....毎にそれぞれ新しい雛形に転記し名前をつけて保存する
11
+ この項目番号毎にそれぞれ新しい雛形に転記し名前をつけて保存する
18
12
 
19
13
  という条件分岐をつけたいです。
20
14
 

1

2021/02/25 06:18

投稿

mkmigmyuch
mkmigmyuch

スコア5

test CHANGED
@@ -1 +1 @@
1
- フォルダ内の全てのExcelを転記し、それぞれ名前をつけて保存するマクロをつくりました。これに、項目番号別に、それぞれ別のブックを作成する昨日を追加したいです。
1
+ フォルダ内の全てのExcelを転記し、それぞれ名前をつけて保存するマクロをつくりました。これに、項目番号別に、それぞれ別のブックを作成する機能を追加したいです。
test CHANGED
File without changes