teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップに関する質問VBA マクロでの転記の実装

編集履歴

質問編集履歴

8

修正

2020/09/27 14:34

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -340,9 +340,7 @@
340
340
 
341
341
  [現状の実行結果]
342
342
 
343
- ![イメージ説明](1d62fbdcb659ccd27b53f293d07e5ee0.png)
343
+ ![イメージ説明](c726e502515b54a23ba1ae0c2f08b8b6.png)
344
-
345
-
346
344
 
347
345
  [実装したい実行結果]
348
346
 

7

ソースの追加

2020/09/27 14:34

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -24,7 +24,7 @@
24
24
 
25
25
 
26
26
 
27
- ----
27
+ ---
28
28
 
29
29
 
30
30
 
@@ -32,215 +32,289 @@
32
32
 
33
33
  ```Macro
34
34
 
35
- Public Sub sample1()
36
-
37
- '-------------------------------------------------------------------------------
38
-
39
- ' sample1
40
-
41
- ' 説明
42
-
43
- ' コピー元のEcxelシート内[更新]シートから内容をコピーする
44
-
45
- ' パラメータ
46
-
47
- ' なし
48
-
49
- ' 戻り値
50
-
51
- ' なし
52
-
53
- '-------------------------------------------------------------------------------
54
-
55
-
56
-
57
- Dim strFromXMLFileName As String ' コピー元となるExcelファイルの名前
58
-
59
- Dim xlsFrom As New Excel.Application ' 取得側Excel
60
-
61
- Dim wbFrom As Workbook ' 取得側Excelブック
62
-
63
- Dim wsFrom As Worksheet ' 取得側Excelシート
64
-
65
- Dim lngFromSheetNo As Long ' 検索するシートの番号
66
-
67
- Dim lngFromRowsNo As Long ' 検索する行位置
68
-
69
-
70
-
71
- Dim wsTo As Worksheet ' 設定側Excelシート
72
-
73
- Dim lngToRowsNo As Long ' 書きこむ行位置
74
-
75
- Dim varKaihatsu As Variant ' [開発]の値
76
-
77
-
78
-
79
- Const strDefaultPath As String = "指定パス" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
80
-
81
-
82
-
83
- On Error GoTo sample1_Error:
84
-
85
-
86
-
87
- ' コピー先の設定
88
-
89
- Set wsTo = ActiveSheet ' 書きこむシートは今開いているシート
90
-
91
- ' 1. コピー先の開始行は2行目から開始とする。
92
-
93
- lngToRowsNo = 2 ' 書きこむ行位置2行目から
94
-
95
-
96
-
97
- ' コピー元となるExcelファイルが置いてあるフォルダのパスからExcelファイルを検索する
98
-
99
- strFromXMLFileName = Dir(strDefaultPath & "*.xls")
100
-
101
-
102
-
103
- ' Excelファイルが見つからなくなるまで検索
104
-
105
- Do Until strFromXMLFileName = ""
106
-
107
-
108
-
109
- ' 見つかったExcelブックを開く
110
-
111
- Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName)
112
-
113
-
114
-
115
- ' 見つかったExcelブックのシートを順番に検索(登録があるシートすべて)
116
-
117
- For lngFromSheetNo = 1 To wbFrom.Worksheets.Count
118
-
119
-
120
-
121
- ' シート名が"更新"のシートを検索
122
-
123
- If wbFrom.Worksheets(lngFromSheetNo).Name = "更新" Then
124
-
125
-
126
-
127
- ' コピー元のシートを設定
128
-
129
- Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)
130
-
131
-
132
-
133
- ' 2. コピー元のシートを1行目から検索(登録がある行すべて)
134
-
135
- For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
136
-
137
-
138
-
139
- ' C列=3 が結合セルの場合
140
-
141
- If wsFrom.Cells(lngFromRowsNo, 3).MergeCells = True Then
142
-
143
- Select Case wsFrom.Cells(lngFromRowsNo, 3).MergeArea.Count
144
-
145
- Case 4
146
-
147
- ' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
148
-
149
- If wsFrom.Cells(lngFromRowsNo, 3).Value = "担当者" Then
150
-
151
- ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
152
-
153
- wsTo.Cells(lngToRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
154
-
155
- ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
156
-
157
- lngToRowsNo = lngToRowsNo + 1
158
-
159
- End If
160
-
161
-
162
-
163
- Case 2
164
-
165
- ' 5. C列が2セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 2 の場合)
166
-
167
- If IsNull(wsFrom.Cells(lngFromRowsNo, 3).Value) = False And wsFrom.Cells(lngFromRowsNo, 3).Value <> "" Then
168
-
169
- ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
170
-
171
-
172
-
173
- ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
174
-
175
- lngToRowsNo = lngToRowsNo + 1
176
-
177
- End If
178
-
179
- End Select
180
-
181
- Else
182
-
183
- Select Case Left(wsFrom.Cells(lngFromRowsNo, 2).Value, 2) 'B列=2 左から2文字を取得
184
-
185
- Case "A1", "A2", "A3"
186
-
187
- ' 3. B列に"A1"or"B1"or"C1"で始まる文字列がある場合、[開発]の値として変数に代入しておく。
188
-
189
- varKaihatsu = wsFrom.Cells(lngFromRowsNo, 2).Value ' [開発]の値
190
-
191
- End Select
35
+ Sub sample1()
36
+
37
+
38
+
39
+ Dim lngRowsNo As Long ' 書きこむ位置(行)
40
+
41
+ Dim lngSheetIndex As Long ' シートの番号
42
+
43
+ Dim strFile As String ' Excelファイルの場所
44
+
45
+ Dim xlsAcq As New Excel.Application ' 取得側Excel
46
+
47
+ Dim wbAcq As Workbook ' 取得側Excelブック
48
+
49
+ Dim wsAcq As Worksheet ' 取得側Excelシート
50
+
51
+ Dim wsSet As Worksheet ' 設定側Excelシート
52
+
53
+ Const strPath As String = "/Users/keiichi/Desktop/マクロ宿題/"
54
+
55
+ Set wsSet = ActiveSheet
56
+
57
+ Dim i As Long
58
+
59
+
60
+
61
+ strFile = Dir(strPath & "*.xls")
62
+
63
+ lngRowsNo = 3 ' 書きこみ開始位置(行)
64
+
65
+ Do Until strFile = ""
66
+
67
+ '----- Excelブックを開く
68
+
69
+ Set wbAcq = Workbooks.Open(strPath & strFile)
70
+
71
+
72
+
73
+ '----- シートを検索
74
+
75
+ For lngSheetIndex = 1 To wbAcq.Worksheets.Count
76
+
77
+ '----- 「更新」シートを検索
78
+
79
+ If wbAcq.Worksheets(lngSheetIndex).Name = "最新" Then
80
+
81
+ '----- 「更新」シートを変数へ登録
82
+
83
+
84
+
85
+ Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
86
+
87
+ '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
88
+
89
+ With wsAcq
90
+
91
+ Dim fname As String 'ファイル名
92
+
93
+ Dim n As Long 'ループで使用します。
94
+
95
+ Dim m As Long 'ループで使用します。
96
+
97
+ Dim ec1 As Long '各開発の一番下の担当者のセルを取得
98
+
99
+ Dim ec2 As Long '各開発の 月の一番右（最後）のセルを取得
100
+
101
+ Dim ec3 As Long '月数を取得
102
+
103
+ Dim ColumnNo As Long ' 転記先の列番号（初期値４）
104
+
105
+ Dim ColumnNo2 As Long ' 転記元の列番号（初期値５）＋３されていく
106
+
107
+
108
+
109
+ ColumnNo = 4
110
+
111
+ ColumnNo2 = 5
112
+
113
+
114
+
115
+ For i = 1 To .UsedRange.Rows.Count
116
+
117
+
118
+
119
+ If (Left(.Cells(i, 2).Value, 2) = "A1" Or Left(.Cells(i, 2).Value, 2) = "B1" Or Left(.Cells(i, 2).Value, 2) = "C1") And .Cells(i, 2).MergeCells = False Then
120
+
121
+
122
+
123
+ '月を取得して転記
124
+
125
+ ec2 = .Cells(i + 1, 5).End(xlToRight).Column + 1
126
+
127
+
128
+
129
+ For col = 5 To ec2
130
+
131
+
132
+
133
+ '「担当者」の転記
134
+
135
+ wsSet.Cells(lngRowsNo - 1, 3).Value = .Cells(i + 1, 3).Value
136
+
137
+
138
+
139
+ '「担当者」以降の 「月」の転記
140
+
141
+ wsSet.Cells(lngRowsNo - 1, ColumnNo).Value = .Cells(i + 1, ColumnNo2).Value
142
+
143
+
144
+
145
+ ColumnNo = ColumnNo + 1
146
+
147
+ ColumnNo2 = ColumnNo2 + 3
148
+
149
+
150
+
151
+ Next col
152
+
153
+
154
+
155
+ ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
156
+
157
+ 'データの入っているところまでループさせる (その時、開発名を転記)
158
+
159
+ ec1 = .Cells(i + 3, 2).End(xlDown).Row
160
+
161
+ For n = i + 3 To ec1
162
+
163
+
164
+
165
+ '担当者が空白の時スキップする
166
+
167
+ If Cells(n, 3) = "" Then
168
+
169
+ GoTo NEXT99
170
+
171
+ End If
172
+
173
+
174
+
175
+ 'ファイル名
176
+
177
+ fname = ActiveWorkbook.Name
178
+
179
+ wsSet.Cells(lngRowsNo, 1).Value = fname
180
+
181
+ If .MergeArea.Count = 4 Then
182
+
183
+ End If
184
+
185
+ 'メソッドまたはデータメンバーが見つかりません
186
+
187
+ '開発
188
+
189
+ wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
190
+
191
+
192
+
193
+ '担当者
194
+
195
+ wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value
196
+
197
+
198
+
199
+ '工数
200
+
201
+ wsSet.Cells(lngRowsNo, 4).Value = .Cells(n, 5).Value
202
+
203
+
204
+
205
+ wsSet.Cells(lngRowsNo, 5).Value = .Cells(n, 8).Value
206
+
207
+
208
+
209
+ wsSet.Cells(lngRowsNo, 6).Value = .Cells(n, 11).Value
210
+
211
+
212
+
213
+ wsSet.Cells(lngRowsNo, 7).Value = .Cells(n, 14).Value
214
+
215
+
216
+
217
+ wsSet.Cells(lngRowsNo, 8).Value = .Cells(n, 17).Value
218
+
219
+
220
+
221
+ wsSet.Cells(lngRowsNo, 9).Value = .Cells(n, 20).Value
222
+
223
+
224
+
225
+ wsSet.Cells(lngRowsNo, 10).Value = .Cells(n, 23).Value
226
+
227
+
228
+
229
+ wsSet.Cells(lngRowsNo, 11).Value = .Cells(n, 26).Value
230
+
231
+
232
+
233
+ wsSet.Cells(lngRowsNo, 12).Value = .Cells(n, 29).Value
234
+
235
+
236
+
237
+ wsSet.Cells(lngRowsNo, 13).Value = .Cells(n, 32).Value
238
+
239
+
240
+
241
+ '１行下へ
242
+
243
+ lngRowsNo = lngRowsNo + 1
244
+
245
+
246
+
247
+ NEXT99:
248
+
249
+ Next n
250
+
251
+
192
252
 
193
253
  End If
194
254
 
195
-
255
+ Next i
256
+
196
-
257
+ End With
258
+
259
+
260
+
197
- Next lngFromRowsNo
261
+ '----- 検索の終了
198
-
199
-
200
-
201
- ' 1つのExcelファイルには同じ名前のシートが作成できないのでシート検索処理を終了する
202
262
 
203
263
  Exit For
204
264
 
205
-
206
-
207
265
  End If
208
266
 
209
-
210
-
211
- Next lngFromSheetNo
267
+ Next lngSheetIndex
268
+
269
+
270
+
212
-
271
+ '----- シート参照の解放
272
+
213
-
273
+ Set wsAcq = Nothing
214
-
274
+
215
- ' 見つかったExcelブックを閉じる
275
+ '----- ブックを閉じる
216
-
276
+
217
- Call wbFrom.Close(True) 'セーブはしない
277
+ wbAcq.Close Savechanges:=False
218
-
219
- Set wbFrom = Nothing '参照の解除
278
+
220
-
221
-
222
-
279
+
280
+
223
- ' 次のExcelファイルを検索
281
+ '----- 次のファイルへ
224
-
282
+
225
- strFromXMLFileName = Dir()
283
+ strFile = Dir()
284
+
285
+
286
+
287
+
226
288
 
227
289
  Loop
228
290
 
229
291
 
230
292
 
231
- sample1_End:
232
-
233
- On Error Resume Next
234
-
235
- Exit Sub
236
-
237
-
238
-
239
- '----- エラー処理
293
+ '----- Excelへの参照の解放
240
-
241
- sample1_Error:
294
+
242
-
243
- Resume sample1_End:
295
+ Set xlsAcq = Nothing
296
+
297
+
298
+
299
+ Dim maxrow As Long '最終行
300
+
301
+ maxrow = wsSet.Cells(Rows.Count, 3).End(xlUp).Row 'C列で最終行を求める
302
+
303
+ For i = 3 To maxrow
304
+
305
+
306
+
307
+ If wsSet.Cells(i, "C").Value = "担当者" Then
308
+
309
+ wsSet.Cells(i, "A").Value = ""
310
+
311
+ wsSet.Cells(i, "B").Value = ""
312
+
313
+ End If
314
+
315
+ Next
316
+
317
+
244
318
 
245
319
  End Sub
246
320
 
@@ -250,6 +324,8 @@
250
324
 
251
325
 
252
326
 
327
+
328
+
253
329
  質問２.xls
254
330
 
255
331
  ![イメージ説明](87a32b680bcfb778bc881f2b8fd38145.png)

6

ソースの修正

2020/09/27 11:37

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -76,7 +76,7 @@
76
76
 
77
77
 
78
78
 
79
- Const strDefaultPath As String = "/Users/keiichi/Desktop/マクロ宿題/" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
79
+ Const strDefaultPath As String = "指定パス" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
80
80
 
81
81
 
82
82
 
@@ -120,7 +120,7 @@
120
120
 
121
121
  ' シート名が"更新"のシートを検索
122
122
 
123
- If wbFrom.Worksheets(lngFromSheetNo).Name = "最新" Then
123
+ If wbFrom.Worksheets(lngFromSheetNo).Name = "更新" Then
124
124
 
125
125
 
126
126
 

5

文言の修正

2020/09/27 11:25

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -28,248 +28,228 @@
28
28
 
29
29
 
30
30
 
31
- [補足]
31
+ [現状のソース]
32
-
33
- 上記の実装をする際に以下のコードをコンパイルしてみたら
34
-
35
- 'メソッドまたはデータメンバーが見つかりません
36
-
37
- というエラーが出てしまいました。。
38
32
 
39
33
  ```Macro
40
34
 
35
+ Public Sub sample1()
36
+
37
+ '-------------------------------------------------------------------------------
38
+
39
+ ' sample1
40
+
41
+ ' 説明
42
+
43
+ ' コピー元のEcxelシート内[更新]シートから内容をコピーする
44
+
45
+ ' パラメータ
46
+
47
+ ' なし
48
+
49
+ ' 戻り値
50
+
51
+ ' なし
52
+
53
+ '-------------------------------------------------------------------------------
54
+
55
+
56
+
57
+ Dim strFromXMLFileName As String ' コピー元となるExcelファイルの名前
58
+
59
+ Dim xlsFrom As New Excel.Application ' 取得側Excel
60
+
61
+ Dim wbFrom As Workbook ' 取得側Excelブック
62
+
63
+ Dim wsFrom As Worksheet ' 取得側Excelシート
64
+
65
+ Dim lngFromSheetNo As Long ' 検索するシートの番号
66
+
67
+ Dim lngFromRowsNo As Long ' 検索する行位置
68
+
69
+
70
+
71
+ Dim wsTo As Worksheet ' 設定側Excelシート
72
+
73
+ Dim lngToRowsNo As Long ' 書きこむ行位置
74
+
75
+ Dim varKaihatsu As Variant ' [開発]の値
76
+
77
+
78
+
79
+ Const strDefaultPath As String = "/Users/keiichi/Desktop/マクロ宿題/" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
80
+
81
+
82
+
83
+ On Error GoTo sample1_Error:
84
+
85
+
86
+
87
+ ' コピー先の設定
88
+
89
+ Set wsTo = ActiveSheet ' 書きこむシートは今開いているシート
90
+
91
+ ' 1. コピー先の開始行は2行目から開始とする。
92
+
93
+ lngToRowsNo = 2 ' 書きこむ行位置2行目から
94
+
95
+
96
+
97
+ ' コピー元となるExcelファイルが置いてあるフォルダのパスからExcelファイルを検索する
98
+
99
+ strFromXMLFileName = Dir(strDefaultPath & "*.xls")
100
+
101
+
102
+
41
- 'メソッドまたはデータメンバーが見つかりません
103
+ ' Excelファイルが見つからなくなるまで検索
104
+
42
-
105
+ Do Until strFromXMLFileName = ""
106
+
107
+
108
+
109
+ ' 見つかったExcelブックを開く
110
+
111
+ Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName)
112
+
113
+
114
+
115
+ ' 見つかったExcelブックのシートを順番に検索(登録があるシートすべて)
116
+
117
+ For lngFromSheetNo = 1 To wbFrom.Worksheets.Count
118
+
119
+
120
+
121
+ ' シート名が"更新"のシートを検索
122
+
123
+ If wbFrom.Worksheets(lngFromSheetNo).Name = "最新" Then
124
+
125
+
126
+
127
+ ' コピー元のシートを設定
128
+
129
+ Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)
130
+
131
+
132
+
133
+ ' 2. コピー元のシートを1行目から検索(登録がある行すべて)
134
+
135
+ For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
136
+
137
+
138
+
139
+ ' C列=3 が結合セルの場合
140
+
43
- If .MergeArea.Count = 4 Then
141
+ If wsFrom.Cells(lngFromRowsNo, 3).MergeCells = True Then
142
+
44
-
143
+ Select Case wsFrom.Cells(lngFromRowsNo, 3).MergeArea.Count
144
+
145
+ Case 4
146
+
147
+ ' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
148
+
149
+ If wsFrom.Cells(lngFromRowsNo, 3).Value = "担当者" Then
150
+
151
+ ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
152
+
153
+ wsTo.Cells(lngToRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
154
+
155
+ ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
156
+
157
+ lngToRowsNo = lngToRowsNo + 1
158
+
45
- End If
159
+ End If
160
+
161
+
162
+
163
+ Case 2
164
+
165
+ ' 5. C列が2セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 2 の場合)
166
+
167
+ If IsNull(wsFrom.Cells(lngFromRowsNo, 3).Value) = False And wsFrom.Cells(lngFromRowsNo, 3).Value <> "" Then
168
+
169
+ ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
170
+
171
+
172
+
173
+ ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
174
+
175
+ lngToRowsNo = lngToRowsNo + 1
176
+
177
+ End If
178
+
179
+ End Select
180
+
181
+ Else
182
+
183
+ Select Case Left(wsFrom.Cells(lngFromRowsNo, 2).Value, 2) 'B列=2 左から2文字を取得
184
+
185
+ Case "A1", "A2", "A3"
186
+
187
+ ' 3. B列に"A1"or"B1"or"C1"で始まる文字列がある場合、[開発]の値として変数に代入しておく。
188
+
189
+ varKaihatsu = wsFrom.Cells(lngFromRowsNo, 2).Value ' [開発]の値
190
+
191
+ End Select
192
+
193
+ End If
194
+
195
+
196
+
197
+ Next lngFromRowsNo
198
+
199
+
200
+
201
+ ' 1つのExcelファイルには同じ名前のシートが作成できないのでシート検索処理を終了する
202
+
203
+ Exit For
204
+
205
+
206
+
207
+ End If
208
+
209
+
210
+
211
+ Next lngFromSheetNo
212
+
213
+
214
+
215
+ ' 見つかったExcelブックを閉じる
216
+
217
+ Call wbFrom.Close(True) 'セーブはしない
218
+
219
+ Set wbFrom = Nothing '参照の解除
220
+
221
+
222
+
223
+ ' 次のExcelファイルを検索
224
+
225
+ strFromXMLFileName = Dir()
226
+
227
+ Loop
228
+
229
+
230
+
231
+ sample1_End:
232
+
233
+ On Error Resume Next
234
+
235
+ Exit Sub
236
+
237
+
238
+
239
+ '----- エラー処理
240
+
241
+ sample1_Error:
242
+
243
+ Resume sample1_End:
244
+
245
+ End Sub
246
+
247
+
46
248
 
47
249
  ```
48
250
 
49
251
 
50
252
 
51
- [現状のソース]
52
-
53
- ```Macro
54
-
55
- Public Sub sample1()
56
-
57
- '-------------------------------------------------------------------------------
58
-
59
- ' sample1
60
-
61
- ' 説明
62
-
63
- ' コピー元のEcxelシート内[更新]シートから内容をコピーする
64
-
65
- ' パラメータ
66
-
67
- ' なし
68
-
69
- ' 戻り値
70
-
71
- ' なし
72
-
73
- '-------------------------------------------------------------------------------
74
-
75
-
76
-
77
- Dim strFromXMLFileName As String ' コピー元となるExcelファイルの名前
78
-
79
- Dim xlsFrom As New Excel.Application ' 取得側Excel
80
-
81
- Dim wbFrom As Workbook ' 取得側Excelブック
82
-
83
- Dim wsFrom As Worksheet ' 取得側Excelシート
84
-
85
- Dim lngFromSheetNo As Long ' 検索するシートの番号
86
-
87
- Dim lngFromRowsNo As Long ' 検索する行位置
88
-
89
-
90
-
91
- Dim wsTo As Worksheet ' 設定側Excelシート
92
-
93
- Dim lngToRowsNo As Long ' 書きこむ行位置
94
-
95
- Dim varKaihatsu As Variant ' [開発]の値
96
-
97
-
98
-
99
- Const strDefaultPath As String = "/Users/keiichi/Desktop/マクロ宿題/" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
100
-
101
-
102
-
103
- On Error GoTo sample1_Error:
104
-
105
-
106
-
107
- ' コピー先の設定
108
-
109
- Set wsTo = ActiveSheet ' 書きこむシートは今開いているシート
110
-
111
- ' 1. コピー先の開始行は2行目から開始とする。
112
-
113
- lngToRowsNo = 2 ' 書きこむ行位置2行目から
114
-
115
-
116
-
117
- ' コピー元となるExcelファイルが置いてあるフォルダのパスからExcelファイルを検索する
118
-
119
- strFromXMLFileName = Dir(strDefaultPath & "*.xls")
120
-
121
-
122
-
123
- ' Excelファイルが見つからなくなるまで検索
124
-
125
- Do Until strFromXMLFileName = ""
126
-
127
-
128
-
129
- ' 見つかったExcelブックを開く
130
-
131
- Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName)
132
-
133
-
134
-
135
- ' 見つかったExcelブックのシートを順番に検索(登録があるシートすべて)
136
-
137
- For lngFromSheetNo = 1 To wbFrom.Worksheets.Count
138
-
139
-
140
-
141
- ' シート名が"更新"のシートを検索
142
-
143
- If wbFrom.Worksheets(lngFromSheetNo).Name = "最新" Then
144
-
145
-
146
-
147
- ' コピー元のシートを設定
148
-
149
- Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)
150
-
151
-
152
-
153
- ' 2. コピー元のシートを1行目から検索(登録がある行すべて)
154
-
155
- For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
156
-
157
-
158
-
159
- ' C列=3 が結合セルの場合
160
-
161
- If wsFrom.Cells(lngFromRowsNo, 3).MergeCells = True Then
162
-
163
- Select Case wsFrom.Cells(lngFromRowsNo, 3).MergeArea.Count
164
-
165
- Case 4
166
-
167
- ' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
168
-
169
- If wsFrom.Cells(lngFromRowsNo, 3).Value = "担当者" Then
170
-
171
- ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
172
-
173
- wsTo.Cells(lngToRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
174
-
175
- ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
176
-
177
- lngToRowsNo = lngToRowsNo + 1
178
-
179
- End If
180
-
181
-
182
-
183
- Case 2
184
-
185
- ' 5. C列が2セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 2 の場合)
186
-
187
- If IsNull(wsFrom.Cells(lngFromRowsNo, 3).Value) = False And wsFrom.Cells(lngFromRowsNo, 3).Value <> "" Then
188
-
189
- ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
190
-
191
-
192
-
193
- ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
194
-
195
- lngToRowsNo = lngToRowsNo + 1
196
-
197
- End If
198
-
199
- End Select
200
-
201
- Else
202
-
203
- Select Case Left(wsFrom.Cells(lngFromRowsNo, 2).Value, 2) 'B列=2 左から2文字を取得
204
-
205
- Case "A1", "A2", "A3"
206
-
207
- ' 3. B列に"A1"or"B1"or"C1"で始まる文字列がある場合、[開発]の値として変数に代入しておく。
208
-
209
- varKaihatsu = wsFrom.Cells(lngFromRowsNo, 2).Value ' [開発]の値
210
-
211
- End Select
212
-
213
- End If
214
-
215
-
216
-
217
- Next lngFromRowsNo
218
-
219
-
220
-
221
- ' 1つのExcelファイルには同じ名前のシートが作成できないのでシート検索処理を終了する
222
-
223
- Exit For
224
-
225
-
226
-
227
- End If
228
-
229
-
230
-
231
- Next lngFromSheetNo
232
-
233
-
234
-
235
- ' 見つかったExcelブックを閉じる
236
-
237
- Call wbFrom.Close(True) 'セーブはしない
238
-
239
- Set wbFrom = Nothing '参照の解除
240
-
241
-
242
-
243
- ' 次のExcelファイルを検索
244
-
245
- strFromXMLFileName = Dir()
246
-
247
- Loop
248
-
249
-
250
-
251
- sample1_End:
252
-
253
- On Error Resume Next
254
-
255
- Exit Sub
256
-
257
-
258
-
259
- '----- エラー処理
260
-
261
- sample1_Error:
262
-
263
- Resume sample1_End:
264
-
265
- End Sub
266
-
267
-
268
-
269
- ```
270
-
271
-
272
-
273
253
  質問２.xls
274
254
 
275
255
  ![イメージ説明](87a32b680bcfb778bc881f2b8fd38145.png)

4

ソースの修正

2020/09/27 10:48

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -170,7 +170,7 @@
170
170
 
171
171
  ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
172
172
 
173
- wsTo.Cells(lngRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
173
+ wsTo.Cells(lngToRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
174
174
 
175
175
  ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
176
176
 
@@ -284,7 +284,7 @@
284
284
 
285
285
  [現状の実行結果]
286
286
 
287
- ![イメージ説明](f33b11430b6d986fda4d495258e05281.png)
287
+ ![イメージ説明](1d62fbdcb659ccd27b53f293d07e5ee0.png)
288
288
 
289
289
 
290
290
 

3

ソースの修正

2020/09/27 10:48

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -96,7 +96,7 @@
96
96
 
97
97
 
98
98
 
99
- Const strDefaultPath As String = "パス指定" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
99
+ Const strDefaultPath As String = "/Users/keiichi/Desktop/マクロ宿題/" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
100
100
 
101
101
 
102
102
 
@@ -140,7 +140,7 @@
140
140
 
141
141
  ' シート名が"更新"のシートを検索
142
142
 
143
- If wbFrom.Worksheets(lngFromSheetNo).Name = "更新" Then
143
+ If wbFrom.Worksheets(lngFromSheetNo).Name = "最新" Then
144
144
 
145
145
 
146
146
 
@@ -170,7 +170,7 @@
170
170
 
171
171
  ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
172
172
 
173
- wsSet.Cells(lngRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
173
+ wsTo.Cells(lngRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
174
174
 
175
175
  ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
176
176
 
@@ -266,8 +266,6 @@
266
266
 
267
267
 
268
268
 
269
-
270
-
271
269
  ```
272
270
 
273
271
 

2

ソース修正

2020/09/27 10:41

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -52,296 +52,222 @@
52
52
 
53
53
  ```Macro
54
54
 
55
- Sub sample1()
56
-
57
-
58
-
59
- Dim lngRowsNo As Long ' 書きこむ位置(行)
60
-
61
- Dim lngSheetIndex As Long ' シートの番号
62
-
63
- Dim strFile As String ' Excelファイルの場所
64
-
65
- Dim xlsAcq As New Excel.Application ' 取得側Excel
66
-
67
- Dim wbAcq As Workbook ' 取得側Excelブック
68
-
69
- Dim wsAcq As Worksheet ' 取得側Excelシート
70
-
71
- Dim wsSet As Worksheet ' 設定側Excelシート
72
-
73
- Const strPath As String = "パスを指定する"
74
-
75
- Set wsSet = ActiveSheet
76
-
77
- Dim i As Long
78
-
79
-
80
-
81
- strFile = Dir(strPath & "*.xls")
82
-
83
- lngRowsNo = 3 ' 書きこみ開始位置(行)
84
-
85
- Do Until strFile = ""
86
-
87
- '----- Excelブックを開く
88
-
89
- Set wbAcq = Workbooks.Open(strPath & strFile)
90
-
91
-
92
-
93
- '----- シートを検索
94
-
95
- For lngSheetIndex = 1 To wbAcq.Worksheets.Count
96
-
97
- '----- 「更新」シートを検索
98
-
99
- If wbAcq.Worksheets(lngSheetIndex).Name = "更新" Then
100
-
101
- '----- 「更新」シートを変数へ登録
102
-
103
-
104
-
105
- Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
106
-
107
- '----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
108
-
109
- With wsAcq
110
-
111
- Dim fname As String 'ファイル名
112
-
113
- Dim n As Long 'ループで使用します。
114
-
115
- Dim m As Long 'ループで使用します。
116
-
117
- Dim ec1 As Long '各開発の一番下の担当者のセルを取得
118
-
119
- Dim ec2 As Long '各開発の 月の一番右（最後）のセルを取得
120
-
121
- Dim ec3 As Long '月数を取得
122
-
123
- Dim ColumnNo As Long ' 転記先の列番号（初期値４）
124
-
125
- Dim ColumnNo2 As Long ' 転記元の列番号（初期値５）＋３されていく
126
-
127
-
128
-
129
- ColumnNo = 4
130
-
131
- ColumnNo2 = 5
132
-
133
-
134
-
135
- For i = 1 To .UsedRange.Rows.Count
136
-
137
-
138
-
139
- If (Left(.Cells(i, 2).Value, 2) = "A1" Or Left(.Cells(i, 2).Value, 2) = "B1" Or Left(.Cells(i, 2).Value, 2) = "C1") And .Cells(i, 2).MergeCells = False Then
140
-
141
-
142
-
143
- '月を取得して転記
144
-
145
- ec2 = .Cells(i + 1, 5).End(xlToRight).Column + 1
146
-
147
-
148
-
149
- For col = 5 To ec2
150
-
151
-
152
-
153
- '「担当者」の転記
154
-
155
- wsSet.Cells(lngRowsNo - 1, 3).Value = .Cells(i + 1, 3).Value
156
-
157
-
158
-
159
- '「担当者」以降の 「月」の転記
160
-
161
- wsSet.Cells(lngRowsNo - 1, ColumnNo).Value = .Cells(i + 1, ColumnNo2).Value
162
-
163
-
164
-
165
- ColumnNo = ColumnNo + 1
166
-
167
- ColumnNo2 = ColumnNo2 + 3
168
-
169
-
170
-
171
- Next col
172
-
173
-
174
-
175
- ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
176
-
177
- 'データの入っているところまでループさせる (その時、開発名を転記)
178
-
179
- ec1 = .Cells(i + 3, 2).End(xlDown).Row
180
-
181
- For n = i + 3 To ec1
182
-
183
-
184
-
185
- '担当者が空白の時スキップする
186
-
187
- If Cells(n, 3) = "" Then
188
-
189
- GoTo NEXT99
190
-
191
- End If
192
-
193
-
194
-
195
- 'ファイル名
196
-
197
- fname = ActiveWorkbook.Name
198
-
199
- wsSet.Cells(lngRowsNo, 1).Value = fname
200
-
201
-
202
-
203
- '開発
204
-
205
- wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
206
-
207
-
208
-
209
- '担当者
210
-
211
- If .MergeArea.Count = 4 Then
212
-
213
- End If
214
-
215
- wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value
216
-
217
-
218
-
219
-
220
-
221
- '工数
222
-
223
- wsSet.Cells(lngRowsNo, 4).Value = .Cells(n, 5).Value
224
-
225
-
226
-
227
- wsSet.Cells(lngRowsNo, 5).Value = .Cells(n, 8).Value
228
-
229
-
230
-
231
- wsSet.Cells(lngRowsNo, 6).Value = .Cells(n, 11).Value
232
-
233
-
234
-
235
- wsSet.Cells(lngRowsNo, 7).Value = .Cells(n, 14).Value
236
-
237
-
238
-
239
- wsSet.Cells(lngRowsNo, 8).Value = .Cells(n, 17).Value
240
-
241
-
242
-
243
- wsSet.Cells(lngRowsNo, 9).Value = .Cells(n, 20).Value
244
-
245
-
246
-
247
- wsSet.Cells(lngRowsNo, 10).Value = .Cells(n, 23).Value
248
-
249
-
250
-
251
- wsSet.Cells(lngRowsNo, 11).Value = .Cells(n, 26).Value
252
-
253
-
254
-
255
- wsSet.Cells(lngRowsNo, 12).Value = .Cells(n, 29).Value
256
-
257
-
258
-
259
- wsSet.Cells(lngRowsNo, 13).Value = .Cells(n, 32).Value
260
-
261
-
262
-
263
- '１行下へ
264
-
265
- lngRowsNo = lngRowsNo + 1
266
-
267
-
268
-
269
- NEXT99:
270
-
271
- Next n
272
-
273
-
55
+ Public Sub sample1()
56
+
57
+ '-------------------------------------------------------------------------------
58
+
59
+ ' sample1
60
+
61
+ ' 説明
62
+
63
+ ' コピー元のEcxelシート内[更新]シートから内容をコピーする
64
+
65
+ ' パラメータ
66
+
67
+ ' なし
68
+
69
+ ' 戻り値
70
+
71
+ ' なし
72
+
73
+ '-------------------------------------------------------------------------------
74
+
75
+
76
+
77
+ Dim strFromXMLFileName As String ' コピー元となるExcelファイルの名前
78
+
79
+ Dim xlsFrom As New Excel.Application ' 取得側Excel
80
+
81
+ Dim wbFrom As Workbook ' 取得側Excelブック
82
+
83
+ Dim wsFrom As Worksheet ' 取得側Excelシート
84
+
85
+ Dim lngFromSheetNo As Long ' 検索するシートの番号
86
+
87
+ Dim lngFromRowsNo As Long ' 検索する行位置
88
+
89
+
90
+
91
+ Dim wsTo As Worksheet ' 設定側Excelシート
92
+
93
+ Dim lngToRowsNo As Long ' 書きこむ行位置
94
+
95
+ Dim varKaihatsu As Variant ' [開発]の値
96
+
97
+
98
+
99
+ Const strDefaultPath As String = "パス指定" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
100
+
101
+
102
+
103
+ On Error GoTo sample1_Error:
104
+
105
+
106
+
107
+ ' コピー先の設定
108
+
109
+ Set wsTo = ActiveSheet ' 書きこむシートは今開いているシート
110
+
111
+ ' 1. コピー先の開始行は2行目から開始とする。
112
+
113
+ lngToRowsNo = 2 ' 書きこむ行位置2行目から
114
+
115
+
116
+
117
+ ' コピー元となるExcelファイルが置いてあるフォルダのパスからExcelファイルを検索する
118
+
119
+ strFromXMLFileName = Dir(strDefaultPath & "*.xls")
120
+
121
+
122
+
123
+ ' Excelファイルが見つからなくなるまで検索
124
+
125
+ Do Until strFromXMLFileName = ""
126
+
127
+
128
+
129
+ ' 見つかったExcelブックを開く
130
+
131
+ Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName)
132
+
133
+
134
+
135
+ ' 見つかったExcelブックのシートを順番に検索(登録があるシートすべて)
136
+
137
+ For lngFromSheetNo = 1 To wbFrom.Worksheets.Count
138
+
139
+
140
+
141
+ ' シート名が"更新"のシートを検索
142
+
143
+ If wbFrom.Worksheets(lngFromSheetNo).Name = "更新" Then
144
+
145
+
146
+
147
+ ' コピー元のシートを設定
148
+
149
+ Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)
150
+
151
+
152
+
153
+ ' 2. コピー元のシートを1行目から検索(登録がある行すべて)
154
+
155
+ For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
156
+
157
+
158
+
159
+ ' C列=3 が結合セルの場合
160
+
161
+ If wsFrom.Cells(lngFromRowsNo, 3).MergeCells = True Then
162
+
163
+ Select Case wsFrom.Cells(lngFromRowsNo, 3).MergeArea.Count
164
+
165
+ Case 4
166
+
167
+ ' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
168
+
169
+ If wsFrom.Cells(lngFromRowsNo, 3).Value = "担当者" Then
170
+
171
+ ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
172
+
173
+ wsSet.Cells(lngRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
174
+
175
+ ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
176
+
177
+ lngToRowsNo = lngToRowsNo + 1
178
+
179
+ End If
180
+
181
+
182
+
183
+ Case 2
184
+
185
+ ' 5. C列が2セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 2 の場合)
186
+
187
+ If IsNull(wsFrom.Cells(lngFromRowsNo, 3).Value) = False And wsFrom.Cells(lngFromRowsNo, 3).Value <> "" Then
188
+
189
+ ' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
190
+
191
+
192
+
193
+ ' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
194
+
195
+ lngToRowsNo = lngToRowsNo + 1
196
+
197
+ End If
198
+
199
+ End Select
200
+
201
+ Else
202
+
203
+ Select Case Left(wsFrom.Cells(lngFromRowsNo, 2).Value, 2) 'B列=2 左から2文字を取得
204
+
205
+ Case "A1", "A2", "A3"
206
+
207
+ ' 3. B列に"A1"or"B1"or"C1"で始まる文字列がある場合、[開発]の値として変数に代入しておく。
208
+
209
+ varKaihatsu = wsFrom.Cells(lngFromRowsNo, 2).Value ' [開発]の値
210
+
211
+ End Select
274
212
 
275
213
  End If
276
214
 
277
- Next i
215
+
278
-
279
- End With
216
+
280
-
281
-
282
-
283
- '----- 検索の終了
217
+ Next lngFromRowsNo
218
+
219
+
220
+
221
+ ' 1つのExcelファイルには同じ名前のシートが作成できないのでシート検索処理を終了する
284
222
 
285
223
  Exit For
286
224
 
225
+
226
+
287
227
  End If
288
228
 
229
+
230
+
289
- Next lngSheetIndex
231
+ Next lngFromSheetNo
290
-
291
-
292
-
293
- '----- シート参照の解放
232
+
294
-
295
- Set wsAcq = Nothing
233
+
296
-
234
+
297
- '----- ブックを閉じる
235
+ ' 見つかったExcelブックを閉じる
298
-
236
+
299
- wbAcq.Close Savechanges:=False
237
+ Call wbFrom.Close(True) 'セーブはしない
238
+
300
-
239
+ Set wbFrom = Nothing '参照の解除
301
-
302
-
240
+
241
+
242
+
303
- '----- 次のファイルへ
243
+ ' 次のExcelファイルを検索
304
-
244
+
305
- strFile = Dir()
245
+ strFromXMLFileName = Dir()
306
-
307
-
308
-
309
-
310
246
 
311
247
  Loop
312
248
 
313
249
 
314
250
 
251
+ sample1_End:
252
+
253
+ On Error Resume Next
254
+
255
+ Exit Sub
256
+
257
+
258
+
315
- '----- Excelへの参照の解放
259
+ '----- エラー処理
260
+
316
-
261
+ sample1_Error:
262
+
317
- Set xlsAcq = Nothing
263
+ Resume sample1_End:
318
-
319
-
320
-
321
- Dim maxrow As Long '最終行
322
-
323
- maxrow = wsSet.Cells(Rows.Count, 3).End(xlUp).Row 'C列で最終行を求める
324
-
325
- For i = 3 To maxrow
326
-
327
-
328
-
329
- If wsSet.Cells(i, "C").Value = "担当者" Then
330
-
331
- wsSet.Cells(i, "A").Value = ""
332
-
333
- wsSet.Cells(i, "B").Value = ""
334
-
335
- End If
336
-
337
- Next
338
-
339
-
340
264
 
341
265
  End Sub
342
266
 
343
267
 
344
268
 
269
+
270
+
345
271
  ```
346
272
 
347
273
 

1

内容の修正

2020/09/27 10:28

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -208,8 +208,14 @@
208
208
 
209
209
  '担当者
210
210
 
211
+ If .MergeArea.Count = 4 Then
212
+
213
+ End If
214
+
211
215
  wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value
212
216
 
217
+
218
+
213
219
 
214
220
 
215
221
  '工数