teratail
回答率
85.48%
質問するログイン新規登録
トップに関する質問VBA マクロでエクセル間の決まった行の転記を実装したいが結果が不正になります。

編集履歴

質問編集履歴

7

タイトルの修正

2020/09/26 21:39

投稿

icecleam
icecleam

スコア46

test CHANGED
@@ -1 +1 @@
1
- VBA マクロでブック間の転記を実装したい
1
+ VBA マクロでエクセル間の決まった行の転記を実装したいが結果が不正になります。
test CHANGED
File without changes

6

内容の修正

2020/09/26 21:39

投稿

icecleam
icecleam

スコア46

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

5

見た目の変更

2020/09/26 21:37

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -10,8 +10,6 @@
10
10
 
11
11
  実装内容
12
12
 
13
-
14
-
15
13
  ----
16
14
 
17
15
  C列が３でセル結合しているとき.MergeCellsがTrueの時に.MergeArea.Count = 3のとき

4

質問内容の見直し

2020/09/26 21:26

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -1,20 +1,52 @@
1
- 以下の現状のソースを実行すると、[現状の実行結果]のようになり、月数が正しく転記されません。
1
+ 以下の「現状のソース」を実行すると、[現状の実行結果]のようになり、「月」が正しく転記されません。
2
-
2
+
3
+
4
+
3
- [実装したい実行結果]のように、開発A1の月数も他の開発と同じように時間の上の行に転記したいのですが、なかなかうまくできずに困っています。。
5
+ そこで、以下の「実装内容」で新たにコードを修正しようと思うのですが、コードの書き方がわからずに困っています。。。
6
+
4
-
7
+ どのようにソースを書けば良いでしょうか、ご教授いただけると幸いです。
8
+
9
+
10
+
5
-
11
+ 実装内容
12
+
13
+
14
+
6
-
15
+ ----
16
+
7
- マクロの記録や過去にご指摘をいただいたことなどを参照したのですが、転記の際に別の箇所も書き変わってしまったりしてうまく実装できませんした。
17
+ C列が３でセル結合しているとき.MergeCellsがTrueの時に.MergeArea.Count = 3のとき
8
-
9
-
10
-
18
+
11
- 質問２.xlsと質問３.xlsの1行目から13行目は全て空白のセルになっています。
19
+ C列に「担当者」という文字列が入っているとき、「年月」の値をコピー先の行へ設定する。
20
+
21
+
22
+
12
-
23
+ C列が2でセル結合しているとき.MergeCellsがTrueの時に.MergeArea.Count = 2のとき
24
+
13
-
25
+ C列に文字列が入っているとき、[担当者][工数]の値をコピー先の行へ設定する。
26
+
27
+
28
+
14
-
29
+ ----
30
+
31
+
32
+
33
+ [補足]
34
+
15
- 申し訳ありませんが、ご助力の程よろしくお願いします。
35
+ 上記の実装をする際に以下のコードをコンパイルしてみたら
36
+
16
-
37
+ 'メソッドまたはデータメンバーが見つかりません
38
+
17
-
39
+ というエラーが出てしまいました。。
40
+
41
+ ```Macro
42
+
43
+ 'メソッドまたはデータメンバーが見つかりません
44
+
45
+ If .MergeArea.Count = 4 Then
46
+
47
+ End If
48
+
49
+ ```
18
50
 
19
51
 
20
52
 
@@ -324,7 +356,7 @@
324
356
 
325
357
  [現状の実行結果]
326
358
 
327
- ![イメージ説明](3badf9c650b5dcfba401e0ac427c11a1.png)
359
+ ![イメージ説明](f33b11430b6d986fda4d495258e05281.png)
328
360
 
329
361
 
330
362
 

3

全体の修正

2020/09/26 21:18

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -26,7 +26,7 @@
26
26
 
27
27
 
28
28
 
29
- Dim lngRowsNo As Long ' 書きこむ位置
29
+ Dim lngRowsNo As Long ' 書きこむ位置(行)
30
30
 
31
31
  Dim lngSheetIndex As Long ' シートの番号
32
32
 
@@ -40,7 +40,7 @@
40
40
 
41
41
  Dim wsSet As Worksheet ' 設定側Excelシート
42
42
 
43
- Const strPath As String = "パスを指定"
43
+ Const strPath As String = "パスを指定する"
44
44
 
45
45
  Set wsSet = ActiveSheet
46
46
 
@@ -48,9 +48,9 @@
48
48
 
49
49
 
50
50
 
51
- strFile = Dir(strPath & "*.xls")
51
+ strFile = Dir(strPath & "*.xls")
52
-
52
+
53
- lngRowsNo = 3
53
+ lngRowsNo = 3 ' 書きこみ開始位置(行)
54
54
 
55
55
  Do Until strFile = ""
56
56
 
@@ -88,6 +88,8 @@
88
88
 
89
89
  Dim ec2 As Long '各開発の 月の一番右（最後）のセルを取得
90
90
 
91
+ Dim ec3 As Long '月数を取得
92
+
91
93
  Dim ColumnNo As Long ' 転記先の列番号（初期値４）
92
94
 
93
95
  Dim ColumnNo2 As Long ' 転記元の列番号（初期値５）＋３されていく
@@ -108,12 +110,38 @@
108
110
 
109
111
 
110
112
 
111
-
113
+ '月を取得して転記
114
+
115
+ ec2 = .Cells(i + 1, 5).End(xlToRight).Column + 1
112
116
 
113
117
 
114
118
 
119
+ For col = 5 To ec2
120
+
115
121
 
116
122
 
123
+ '「担当者」の転記
124
+
125
+ wsSet.Cells(lngRowsNo - 1, 3).Value = .Cells(i + 1, 3).Value
126
+
127
+
128
+
129
+ '「担当者」以降の 「月」の転記
130
+
131
+ wsSet.Cells(lngRowsNo - 1, ColumnNo).Value = .Cells(i + 1, ColumnNo2).Value
132
+
133
+
134
+
135
+ ColumnNo = ColumnNo + 1
136
+
137
+ ColumnNo2 = ColumnNo2 + 3
138
+
139
+
140
+
141
+ Next col
142
+
143
+
144
+
117
145
  ' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
118
146
 
119
147
  'データの入っているところまでループさせる (その時、開発名を転記)
@@ -276,6 +304,8 @@
276
304
 
277
305
  End Sub
278
306
 
307
+
308
+
279
309
  ```
280
310
 
281
311
 
@@ -294,7 +324,7 @@
294
324
 
295
325
  [現状の実行結果]
296
326
 
297
- ![イメージ説明](b3fd1046ff80b8b1ab1cc1d568ad90a4.png)
327
+ ![イメージ説明](3badf9c650b5dcfba401e0ac427c11a1.png)
298
328
 
299
329
 
300
330
 

2

内容の追記

2020/09/26 20:57

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -8,6 +8,10 @@
8
8
 
9
9
 
10
10
 
11
+ 質問２.xlsと質問３.xlsの1行目から13行目は全て空白のセルになっています。
12
+
13
+
14
+
11
15
  申し訳ありませんが、ご助力の程よろしくお願いします。
12
16
 
13
17
 

1

文言の修正

2020/09/26 18:51

投稿

icecleam
icecleam

スコア46

test CHANGED
File without changes
test CHANGED
@@ -12,6 +12,8 @@
12
12
 
13
13
 
14
14
 
15
+
16
+
15
17
  [現状のソース]
16
18
 
17
19
  ```Macro