回答編集履歴
4
コードを修正しました\(2\)
test
CHANGED
|
@@ -538,7 +538,7 @@
|
|
|
538
538
|
|
|
539
539
|
UseEnclose = True
|
|
540
540
|
|
|
541
|
-
result = Mid(strInput,
|
|
541
|
+
result = Mid(strInput, Len(symbol) + 1, Len(strInput) - Len(symbol) * 2) '前後のシンボルを除去
|
|
542
542
|
|
|
543
543
|
result = Replace(result, escape, symbol) 'エスケープの処理
|
|
544
544
|
|
3
コードの修正を行いました
test
CHANGED
|
@@ -68,6 +68,8 @@
|
|
|
68
68
|
|
|
69
69
|
**追記 2015/11/19**
|
|
70
70
|
|
|
71
|
+
**編集 2015/11/20 コードを修正しました**
|
|
72
|
+
|
|
71
73
|
グラフのデータ範囲をチェックして、適切でないと判断した場合に範囲を修正するサンプルを書きました。
|
|
72
74
|
|
|
73
75
|
末尾の無効(値の入っていないセル)を除外するだけでなく、不足があれば拡張(範囲を拡大)されるようになっています。拡張が不要であれば拡張をしない形に修正できます。
|
|
@@ -78,6 +80,8 @@
|
|
|
78
80
|
|
|
79
81
|
「ChartCheckMain」を実行頂ければ、アクティブなシート上に存在する全てのグラフについて処理をします。
|
|
80
82
|
|
|
83
|
+
** 2015/11/20 11:50頃 修正済みのコードです**
|
|
84
|
+
|
|
81
85
|
```VBA
|
|
82
86
|
|
|
83
87
|
'<summary>
|
|
@@ -118,8 +122,6 @@
|
|
|
118
122
|
|
|
119
123
|
|
|
120
124
|
|
|
121
|
-
|
|
122
|
-
|
|
123
125
|
'<summary>
|
|
124
126
|
|
|
125
127
|
' グラフのデータ範囲をチェックし、無効な範囲を除去
|
|
@@ -140,6 +142,20 @@
|
|
|
140
142
|
|
|
141
143
|
|
|
142
144
|
|
|
145
|
+
Const ENCLOSE_SYMBOL As String = "'"
|
|
146
|
+
|
|
147
|
+
Const SYMBOL_ESCAPE As String = "''"
|
|
148
|
+
|
|
149
|
+
Const ARGS_PATTERN As String = "\((\(.+\)|[^()]*),(\(.+\)|[^()]*),(.+?),(\d+)\)$"
|
|
150
|
+
|
|
151
|
+
Const RANGE_PATTERN As String = "^('.+'|[^']+)!([^!]+)$"
|
|
152
|
+
|
|
153
|
+
|
|
154
|
+
|
|
155
|
+
Dim Regex 'VBScript.RegExp
|
|
156
|
+
|
|
157
|
+
Dim Matches 'RegExp.Matches
|
|
158
|
+
|
|
143
159
|
Dim SrsCol As SeriesCollection '系列のコレクション
|
|
144
160
|
|
|
145
161
|
Dim SrsCnt As Integer '系列数
|
|
@@ -158,14 +174,14 @@
|
|
|
158
174
|
|
|
159
175
|
Dim SrsOrder As String 'オーダー
|
|
160
176
|
|
|
161
|
-
Dim Params 'パラメータ(分解用)
|
|
162
|
-
|
|
163
177
|
Dim ShtName As String 'データの存在するシート名
|
|
164
178
|
|
|
165
179
|
Dim RngStr As String '範囲を示す文字列
|
|
166
180
|
|
|
167
181
|
Dim Rng As Range 'Range
|
|
168
182
|
|
|
183
|
+
Dim ColEnd As Long 'データ範囲の終端(列)
|
|
184
|
+
|
|
169
185
|
Dim NewRng As Range 'チェックによって決定されたデータ範囲
|
|
170
186
|
|
|
171
187
|
Dim NewSrsLabels As String 'チェックによって決定されたラベル(SERIESの第2引数)
|
|
@@ -176,6 +192,8 @@
|
|
|
176
192
|
|
|
177
193
|
Dim NewFormula As String 'チェックによって決定されたFormulaの値
|
|
178
194
|
|
|
195
|
+
Dim UseEnclose As Boolean
|
|
196
|
+
|
|
179
197
|
|
|
180
198
|
|
|
181
199
|
DataRangeChecker = False
|
|
@@ -184,6 +202,20 @@
|
|
|
184
202
|
|
|
185
203
|
Debug.Print "=========================================="
|
|
186
204
|
|
|
205
|
+
|
|
206
|
+
|
|
207
|
+
Set Regex = CreateObject("VBScript.RegExp")
|
|
208
|
+
|
|
209
|
+
If Err.Number <> 0 Then
|
|
210
|
+
|
|
211
|
+
Debug.Print "> VBScript.RegExpが取得できませんでした"
|
|
212
|
+
|
|
213
|
+
Exit Function
|
|
214
|
+
|
|
215
|
+
End If
|
|
216
|
+
|
|
217
|
+
|
|
218
|
+
|
|
187
219
|
Debug.Print "Target Chart : " & ChrtObj.Name
|
|
188
220
|
|
|
189
221
|
|
|
@@ -218,15 +250,39 @@
|
|
|
218
250
|
|
|
219
251
|
'文字列から情報を抽出
|
|
220
252
|
|
|
253
|
+
With Regex
|
|
254
|
+
|
|
255
|
+
.Pattern = ARGS_PATTERN
|
|
256
|
+
|
|
257
|
+
.IgnoreCase = False
|
|
258
|
+
|
|
259
|
+
.Global = True
|
|
260
|
+
|
|
221
|
-
|
|
261
|
+
Set Matches = .Execute(FormulaValue)
|
|
262
|
+
|
|
222
|
-
|
|
263
|
+
End With
|
|
264
|
+
|
|
265
|
+
|
|
266
|
+
|
|
267
|
+
If Matches.Count > 0 Then
|
|
268
|
+
|
|
223
|
-
SrsName =
|
|
269
|
+
SrsName = Matches(0).SubMatches.Item(0) '凡例の表示
|
|
224
|
-
|
|
270
|
+
|
|
225
|
-
SrsLabels =
|
|
271
|
+
SrsLabels = Matches(0).SubMatches.Item(1) '項目軸のラベル
|
|
226
|
-
|
|
272
|
+
|
|
227
|
-
SrsValues =
|
|
273
|
+
SrsValues = Matches(0).SubMatches.Item(2) '値
|
|
228
|
-
|
|
274
|
+
|
|
229
|
-
SrsOrder =
|
|
275
|
+
SrsOrder = Matches(0).SubMatches.Item(3) 'オーダー
|
|
276
|
+
|
|
277
|
+
Else
|
|
278
|
+
|
|
279
|
+
Debug.Print " > 情報の抽出に失敗しました"
|
|
280
|
+
|
|
281
|
+
SrsName = SrsLabels = SrsValues = SrsOrder = ""
|
|
282
|
+
|
|
283
|
+
GoTo CONTINUE_FOR
|
|
284
|
+
|
|
285
|
+
End If
|
|
230
286
|
|
|
231
287
|
|
|
232
288
|
|
|
@@ -246,15 +302,33 @@
|
|
|
246
302
|
|
|
247
303
|
'-------------------------------------
|
|
248
304
|
|
|
305
|
+
With Regex
|
|
306
|
+
|
|
307
|
+
.Pattern = RANGE_PATTERN
|
|
308
|
+
|
|
309
|
+
.IgnoreCase = False
|
|
310
|
+
|
|
311
|
+
.Global = True
|
|
312
|
+
|
|
313
|
+
|
|
314
|
+
|
|
315
|
+
Set Matches = .Execute(SrsValues)
|
|
316
|
+
|
|
317
|
+
End With
|
|
318
|
+
|
|
319
|
+
|
|
320
|
+
|
|
249
|
-
If
|
|
321
|
+
If Matches.Count > 0 Then
|
|
250
|
-
|
|
251
|
-
|
|
322
|
+
|
|
252
|
-
|
|
253
|
-
ShtName =
|
|
323
|
+
ShtName = Matches(0).SubMatches.Item(0) 'シート名
|
|
254
|
-
|
|
324
|
+
|
|
255
|
-
RngStr =
|
|
325
|
+
RngStr = Matches(0).SubMatches.Item(1) 'データ範囲
|
|
326
|
+
|
|
327
|
+
|
|
328
|
+
|
|
256
|
-
|
|
329
|
+
ShtName = CheckEnclose(ShtName, ENCLOSE_SYMBOL, SYMBOL_ESCAPE, UseEnclose)
|
|
257
|
-
|
|
330
|
+
|
|
331
|
+
|
|
258
332
|
|
|
259
333
|
'データ範囲のチェック
|
|
260
334
|
|
|
@@ -264,76 +338,122 @@
|
|
|
264
338
|
|
|
265
339
|
Set NewRng = .Range(.Cells(Rng.Row, Rng.Column), .Cells(Rng.Row, Rng.End(xlToRight).Column))
|
|
266
340
|
|
|
341
|
+
End With
|
|
342
|
+
|
|
267
|
-
|
|
343
|
+
NewColumnCnt = NewRng.Columns.Count
|
|
344
|
+
|
|
345
|
+
If UseEnclose = True Then
|
|
346
|
+
|
|
347
|
+
NewSrsValues = ENCLOSE_SYMBOL _
|
|
348
|
+
|
|
349
|
+
+ Replace(ShtName, ENCLOSE_SYMBOL, SYMBOL_ESCAPE) _
|
|
350
|
+
|
|
351
|
+
+ ENCLOSE_SYMBOL _
|
|
352
|
+
|
|
353
|
+
+ "!" + NewRng.Address
|
|
354
|
+
|
|
355
|
+
Else
|
|
268
356
|
|
|
269
357
|
NewSrsValues = ShtName + "!" + NewRng.Address
|
|
270
358
|
|
|
359
|
+
End If
|
|
360
|
+
|
|
361
|
+
|
|
362
|
+
|
|
363
|
+
Else
|
|
364
|
+
|
|
365
|
+
'第3引数に!が存在しなかった
|
|
366
|
+
|
|
367
|
+
NewSrsValues = SrsValues
|
|
368
|
+
|
|
369
|
+
End If
|
|
370
|
+
|
|
371
|
+
|
|
372
|
+
|
|
373
|
+
'現在のデータ範囲とチェックによって決定されたデータ範囲を比較
|
|
374
|
+
|
|
375
|
+
If SrsValues = NewSrsValues Then
|
|
376
|
+
|
|
377
|
+
'一致した場合は次の系列へ
|
|
378
|
+
|
|
379
|
+
Debug.Print " > データ範囲の変更は行われませんでした"
|
|
380
|
+
|
|
381
|
+
GoTo CONTINUE_FOR
|
|
382
|
+
|
|
383
|
+
End If
|
|
384
|
+
|
|
385
|
+
|
|
386
|
+
|
|
387
|
+
'-----------------------------------------
|
|
388
|
+
|
|
389
|
+
'SERIESの第2引数(項目軸のラベル)をチェック
|
|
390
|
+
|
|
391
|
+
'-----------------------------------------
|
|
392
|
+
|
|
393
|
+
With Regex
|
|
394
|
+
|
|
395
|
+
.Pattern = RANGE_PATTERN
|
|
396
|
+
|
|
397
|
+
.IgnoreCase = False
|
|
398
|
+
|
|
399
|
+
.Global = True
|
|
400
|
+
|
|
401
|
+
Set Matches = .Execute(SrsLabels)
|
|
402
|
+
|
|
403
|
+
End With
|
|
404
|
+
|
|
405
|
+
|
|
406
|
+
|
|
407
|
+
If Matches.Count > 0 Then
|
|
408
|
+
|
|
409
|
+
ShtName = Matches(0).SubMatches.Item(0) 'シート名
|
|
410
|
+
|
|
411
|
+
RngStr = Matches(0).SubMatches.Item(1) 'データ範囲
|
|
412
|
+
|
|
413
|
+
|
|
414
|
+
|
|
415
|
+
ShtName = CheckEnclose(ShtName, ENCLOSE_SYMBOL, SYMBOL_ESCAPE, UseEnclose)
|
|
416
|
+
|
|
417
|
+
|
|
418
|
+
|
|
419
|
+
'ラベルの範囲を決定
|
|
420
|
+
|
|
421
|
+
With WBk.Worksheets.Item(ShtName)
|
|
422
|
+
|
|
423
|
+
Set Rng = .Range(RngStr)
|
|
424
|
+
|
|
425
|
+
Set NewRng = .Range(.Cells(Rng.Row, Rng.Column), .Cells(Rng.Row, Rng.Column + NewColumnCnt - 1))
|
|
426
|
+
|
|
271
427
|
End With
|
|
272
428
|
|
|
429
|
+
If UseEnclose = True Then
|
|
430
|
+
|
|
431
|
+
NewSrsLabels = ENCLOSE_SYMBOL _
|
|
432
|
+
|
|
433
|
+
+ Replace(ShtName, ENCLOSE_SYMBOL, SYMBOL_ESCAPE) _
|
|
434
|
+
|
|
435
|
+
+ ENCLOSE_SYMBOL _
|
|
436
|
+
|
|
437
|
+
+ "!" + NewRng.Address
|
|
438
|
+
|
|
439
|
+
Else
|
|
440
|
+
|
|
441
|
+
NewSrsLabels = ShtName + "!" + NewRng.Address
|
|
442
|
+
|
|
443
|
+
End If
|
|
444
|
+
|
|
273
445
|
|
|
274
446
|
|
|
275
447
|
Else
|
|
276
448
|
|
|
277
|
-
'第
|
|
449
|
+
'第2引数に!が存在しなかった
|
|
278
|
-
|
|
450
|
+
|
|
279
|
-
NewSrs
|
|
451
|
+
NewSrsLabels = SrsLabels
|
|
280
452
|
|
|
281
453
|
End If
|
|
282
454
|
|
|
283
455
|
|
|
284
456
|
|
|
285
|
-
'現在のデータ範囲とチェックによって決定されたデータ範囲を比較
|
|
286
|
-
|
|
287
|
-
If SrsValues = NewSrsValues Then
|
|
288
|
-
|
|
289
|
-
'一致した場合は次の系列へ
|
|
290
|
-
|
|
291
|
-
Debug.Print " > データ範囲の変更は行われませんでした"
|
|
292
|
-
|
|
293
|
-
GoTo CONTINUE_FOR
|
|
294
|
-
|
|
295
|
-
End If
|
|
296
|
-
|
|
297
|
-
|
|
298
|
-
|
|
299
|
-
'-----------------------------------------
|
|
300
|
-
|
|
301
|
-
'SERIESの第2引数(項目軸のラベル)をチェック
|
|
302
|
-
|
|
303
|
-
'-----------------------------------------
|
|
304
|
-
|
|
305
|
-
If InStr(SrsLabels, "!") > 0 Then
|
|
306
|
-
|
|
307
|
-
Params = Split(SrsLabels, "!")
|
|
308
|
-
|
|
309
|
-
ShtName = Params(0) 'シート名
|
|
310
|
-
|
|
311
|
-
RngStr = Params(1) 'ラベル範囲
|
|
312
|
-
|
|
313
|
-
|
|
314
|
-
|
|
315
|
-
'ラベルの範囲を決定
|
|
316
|
-
|
|
317
|
-
With WBk.Worksheets.Item(ShtName)
|
|
318
|
-
|
|
319
|
-
Set Rng = .Range(RngStr)
|
|
320
|
-
|
|
321
|
-
Set NewRng = .Range(.Cells(Rng.Row, Rng.Column), .Cells(Rng.Row, Rng.Column + NewColumnCnt - 1))
|
|
322
|
-
|
|
323
|
-
NewSrsLabels = ShtName + "!" + NewRng.Address
|
|
324
|
-
|
|
325
|
-
End With
|
|
326
|
-
|
|
327
|
-
|
|
328
|
-
|
|
329
|
-
Else
|
|
330
|
-
|
|
331
|
-
'第2引数に!が存在しなかった
|
|
332
|
-
|
|
333
|
-
NewSrsLabels = SrsLabels
|
|
334
|
-
|
|
335
|
-
End If
|
|
336
|
-
|
|
337
457
|
|
|
338
458
|
|
|
339
459
|
'新しくFormulaに設定する文字列を生成
|
|
@@ -352,13 +472,15 @@
|
|
|
352
472
|
|
|
353
473
|
'生成したFormulaの値を系列に適用
|
|
354
474
|
|
|
355
|
-
Srs.Formula = NewFormula
|
|
475
|
+
If Err.Number = 0 Then Srs.Formula = NewFormula
|
|
356
|
-
|
|
357
|
-
|
|
476
|
+
|
|
477
|
+
|
|
358
478
|
|
|
359
479
|
CONTINUE_FOR:
|
|
360
480
|
|
|
481
|
+
|
|
482
|
+
|
|
361
|
-
If Err.Number <> 0 Then E
|
|
483
|
+
If Err.Number <> 0 Then GoTo EXIT_FUNCTION
|
|
362
484
|
|
|
363
485
|
|
|
364
486
|
|
|
@@ -366,16 +488,76 @@
|
|
|
366
488
|
|
|
367
489
|
|
|
368
490
|
|
|
491
|
+
|
|
492
|
+
|
|
493
|
+
EXIT_FUNCTION:
|
|
494
|
+
|
|
495
|
+
If Err.Number = 0 Then
|
|
496
|
+
|
|
369
|
-
Debug.Print Chr(10) & "> 正常に終了しました" & Chr(10)
|
|
497
|
+
Debug.Print Chr(10) & "> 正常に終了しました" & Chr(10)
|
|
370
|
-
|
|
371
|
-
|
|
372
|
-
|
|
498
|
+
|
|
373
|
-
DataRangeChecker = True
|
|
499
|
+
DataRangeChecker = True
|
|
500
|
+
|
|
374
|
-
|
|
501
|
+
End If
|
|
502
|
+
|
|
503
|
+
|
|
504
|
+
|
|
375
|
-
|
|
505
|
+
Set Regex = Nothing
|
|
376
506
|
|
|
377
507
|
End Function
|
|
378
508
|
|
|
509
|
+
|
|
510
|
+
|
|
511
|
+
'<summay>
|
|
512
|
+
|
|
513
|
+
' 指定の文字列がsymbolで囲まれているかチェック
|
|
514
|
+
|
|
515
|
+
'</summary>
|
|
516
|
+
|
|
517
|
+
'<param name="strInput">チェック対象の文字列</param>
|
|
518
|
+
|
|
519
|
+
'<param name="symbol">シンボル</param>
|
|
520
|
+
|
|
521
|
+
'<param name="escape">エスケープ</param>
|
|
522
|
+
|
|
523
|
+
'<param name="UseEnclose">シンボルで囲まれているかを返す</param>
|
|
524
|
+
|
|
525
|
+
'<returns>囲っているシンボルを除去した文字列を返す</returns>
|
|
526
|
+
|
|
527
|
+
Function CheckEnclose(strInput As String, symbol As String, escape As String, _
|
|
528
|
+
|
|
529
|
+
ByRef UseEnclose As Boolean) As String
|
|
530
|
+
|
|
531
|
+
Dim result As String
|
|
532
|
+
|
|
533
|
+
|
|
534
|
+
|
|
535
|
+
If Left(strInput, Len(symbol)) = symbol And Right(strInput, Len(symbol)) = symbol Then
|
|
536
|
+
|
|
537
|
+
'文字列がsymbolで囲まれている
|
|
538
|
+
|
|
539
|
+
UseEnclose = True
|
|
540
|
+
|
|
541
|
+
result = Mid(strInput, 2, Len(strInput) - Len(symbol) * 2) '前後のシンボルを除去
|
|
542
|
+
|
|
543
|
+
result = Replace(result, escape, symbol) 'エスケープの処理
|
|
544
|
+
|
|
545
|
+
Else
|
|
546
|
+
|
|
547
|
+
'文字列がsymbolで囲まれていない
|
|
548
|
+
|
|
549
|
+
UseEnclose = False
|
|
550
|
+
|
|
551
|
+
result = strInput
|
|
552
|
+
|
|
553
|
+
End If
|
|
554
|
+
|
|
555
|
+
|
|
556
|
+
|
|
557
|
+
CheckEnclose = result
|
|
558
|
+
|
|
559
|
+
End Function
|
|
560
|
+
|
|
379
561
|
```
|
|
380
562
|
|
|
381
563
|
・データ範囲内に歯抜けが存在する事を想定していない(あいだに空のセルが入らない)
|
2
コードを一部修正しました
test
CHANGED
|
@@ -166,8 +166,6 @@
|
|
|
166
166
|
|
|
167
167
|
Dim Rng As Range 'Range
|
|
168
168
|
|
|
169
|
-
Dim ColEnd As Long 'データ範囲の終端(列)
|
|
170
|
-
|
|
171
169
|
Dim NewRng As Range 'チェックによって決定されたデータ範囲
|
|
172
170
|
|
|
173
171
|
Dim NewSrsLabels As String 'チェックによって決定されたラベル(SERIESの第2引数)
|
1
サンプルコード等を追加しました
test
CHANGED
|
@@ -57,3 +57,395 @@
|
|
|
57
57
|
|
|
58
58
|
|
|
59
59
|
この辺りの条件が決まっていれば、実現は可能だと思います。
|
|
60
|
+
|
|
61
|
+
|
|
62
|
+
|
|
63
|
+
|
|
64
|
+
|
|
65
|
+
---
|
|
66
|
+
|
|
67
|
+
|
|
68
|
+
|
|
69
|
+
**追記 2015/11/19**
|
|
70
|
+
|
|
71
|
+
グラフのデータ範囲をチェックして、適切でないと判断した場合に範囲を修正するサンプルを書きました。
|
|
72
|
+
|
|
73
|
+
末尾の無効(値の入っていないセル)を除外するだけでなく、不足があれば拡張(範囲を拡大)されるようになっています。拡張が不要であれば拡張をしない形に修正できます。
|
|
74
|
+
|
|
75
|
+
|
|
76
|
+
|
|
77
|
+
少し"ごちゃっ"としてしまいましたが、以下のコードで動作確認できています。
|
|
78
|
+
|
|
79
|
+
「ChartCheckMain」を実行頂ければ、アクティブなシート上に存在する全てのグラフについて処理をします。
|
|
80
|
+
|
|
81
|
+
```VBA
|
|
82
|
+
|
|
83
|
+
'<summary>
|
|
84
|
+
|
|
85
|
+
' アクティブなシート上に存在する全グラフをチェックする
|
|
86
|
+
|
|
87
|
+
'</summary>
|
|
88
|
+
|
|
89
|
+
Sub ChartCheckMain()
|
|
90
|
+
|
|
91
|
+
Dim AtvWbk As Workbook
|
|
92
|
+
|
|
93
|
+
Dim AtvSht As Worksheet
|
|
94
|
+
|
|
95
|
+
Dim ChrtObj As ChartObject
|
|
96
|
+
|
|
97
|
+
Dim ChrtCnt As Integer
|
|
98
|
+
|
|
99
|
+
Dim ChrtIdx As Integer
|
|
100
|
+
|
|
101
|
+
Dim ret As Boolean
|
|
102
|
+
|
|
103
|
+
|
|
104
|
+
|
|
105
|
+
Set AtvWbk = ActiveWorkbook
|
|
106
|
+
|
|
107
|
+
Set AtvSht = AtvWbk.ActiveSheet
|
|
108
|
+
|
|
109
|
+
|
|
110
|
+
|
|
111
|
+
For Each ChrtObj In AtvSht.ChartObjects
|
|
112
|
+
|
|
113
|
+
ret = DataRangeChecker(AtvWbk, ChrtObj)
|
|
114
|
+
|
|
115
|
+
Next ChrtObj
|
|
116
|
+
|
|
117
|
+
End Sub
|
|
118
|
+
|
|
119
|
+
|
|
120
|
+
|
|
121
|
+
|
|
122
|
+
|
|
123
|
+
'<summary>
|
|
124
|
+
|
|
125
|
+
' グラフのデータ範囲をチェックし、無効な範囲を除去
|
|
126
|
+
|
|
127
|
+
'</summary>
|
|
128
|
+
|
|
129
|
+
'<param name="WBk">Workbook</param>
|
|
130
|
+
|
|
131
|
+
'<param name="ChrtObj">チェック対象のChartObject</param>
|
|
132
|
+
|
|
133
|
+
'<returns>関数の成否</returns>
|
|
134
|
+
|
|
135
|
+
Function DataRangeChecker(ByRef WBk As Workbook, ByRef ChrtObj As ChartObject) As Boolean
|
|
136
|
+
|
|
137
|
+
On Error Resume Next
|
|
138
|
+
|
|
139
|
+
Err.Clear
|
|
140
|
+
|
|
141
|
+
|
|
142
|
+
|
|
143
|
+
Dim SrsCol As SeriesCollection '系列のコレクション
|
|
144
|
+
|
|
145
|
+
Dim SrsCnt As Integer '系列数
|
|
146
|
+
|
|
147
|
+
Dim SrsIdx As Integer '系列のインデックス
|
|
148
|
+
|
|
149
|
+
Dim Srs As Series '系列
|
|
150
|
+
|
|
151
|
+
Dim FormulaValue As String 'Formulaの値
|
|
152
|
+
|
|
153
|
+
Dim SrsName As String '凡例の表示
|
|
154
|
+
|
|
155
|
+
Dim SrsLabels As String '項目軸のラベル
|
|
156
|
+
|
|
157
|
+
Dim SrsValues As String '値(プロット対象のデータ範囲)
|
|
158
|
+
|
|
159
|
+
Dim SrsOrder As String 'オーダー
|
|
160
|
+
|
|
161
|
+
Dim Params 'パラメータ(分解用)
|
|
162
|
+
|
|
163
|
+
Dim ShtName As String 'データの存在するシート名
|
|
164
|
+
|
|
165
|
+
Dim RngStr As String '範囲を示す文字列
|
|
166
|
+
|
|
167
|
+
Dim Rng As Range 'Range
|
|
168
|
+
|
|
169
|
+
Dim ColEnd As Long 'データ範囲の終端(列)
|
|
170
|
+
|
|
171
|
+
Dim NewRng As Range 'チェックによって決定されたデータ範囲
|
|
172
|
+
|
|
173
|
+
Dim NewSrsLabels As String 'チェックによって決定されたラベル(SERIESの第2引数)
|
|
174
|
+
|
|
175
|
+
Dim NewSrsValues As String 'チェックによって決定された値(SERIESの第3引数)
|
|
176
|
+
|
|
177
|
+
Dim NewColumnCnt As Long 'チェックによって決定されたデータ範囲の大きさ(列数)
|
|
178
|
+
|
|
179
|
+
Dim NewFormula As String 'チェックによって決定されたFormulaの値
|
|
180
|
+
|
|
181
|
+
|
|
182
|
+
|
|
183
|
+
DataRangeChecker = False
|
|
184
|
+
|
|
185
|
+
|
|
186
|
+
|
|
187
|
+
Debug.Print "=========================================="
|
|
188
|
+
|
|
189
|
+
Debug.Print "Target Chart : " & ChrtObj.Name
|
|
190
|
+
|
|
191
|
+
|
|
192
|
+
|
|
193
|
+
Set SrsCol = ChrtObj.Chart.SeriesCollection '系列のコレクションを取得
|
|
194
|
+
|
|
195
|
+
SrsCnt = SrsCol.Count
|
|
196
|
+
|
|
197
|
+
Debug.Print "Series.Count : " & CStr(SrsCnt)
|
|
198
|
+
|
|
199
|
+
|
|
200
|
+
|
|
201
|
+
'引数で受け取ったChrtObjが無効であれば関数を抜ける
|
|
202
|
+
|
|
203
|
+
If Err.Number <> 0 Then Exit Function
|
|
204
|
+
|
|
205
|
+
|
|
206
|
+
|
|
207
|
+
'全ての系列についてチェック
|
|
208
|
+
|
|
209
|
+
For SrsIdx = 1 To SrsCnt
|
|
210
|
+
|
|
211
|
+
Set Srs = SrsCol.Item(SrsIdx)
|
|
212
|
+
|
|
213
|
+
FormulaValue = Srs.Formula
|
|
214
|
+
|
|
215
|
+
Debug.Print Chr(10) & "Series[" & CStr(SrsIdx) & "]"
|
|
216
|
+
|
|
217
|
+
Debug.Print " Formula" & FormulaValue
|
|
218
|
+
|
|
219
|
+
|
|
220
|
+
|
|
221
|
+
'文字列から情報を抽出
|
|
222
|
+
|
|
223
|
+
Params = Split(FormulaValue, ",")
|
|
224
|
+
|
|
225
|
+
SrsName = Replace(Params(0), "=SERIES(", "") '凡例の表示
|
|
226
|
+
|
|
227
|
+
SrsLabels = Params(1) '項目軸のラベル
|
|
228
|
+
|
|
229
|
+
SrsValues = Params(2) '値
|
|
230
|
+
|
|
231
|
+
SrsOrder = Replace(Params(3), ")", "") 'オーダー
|
|
232
|
+
|
|
233
|
+
|
|
234
|
+
|
|
235
|
+
Debug.Print " Param(0) = " & SrsName
|
|
236
|
+
|
|
237
|
+
Debug.Print " Param(1) = " & SrsLabels
|
|
238
|
+
|
|
239
|
+
Debug.Print " Param(2) = " & SrsValues
|
|
240
|
+
|
|
241
|
+
Debug.Print " Param(3) = " & SrsOrder
|
|
242
|
+
|
|
243
|
+
|
|
244
|
+
|
|
245
|
+
'-------------------------------------
|
|
246
|
+
|
|
247
|
+
'SERIESの第3引数(データ範囲)のチェック
|
|
248
|
+
|
|
249
|
+
'-------------------------------------
|
|
250
|
+
|
|
251
|
+
If InStr(SrsValues, "!") > 0 Then
|
|
252
|
+
|
|
253
|
+
Params = Split(SrsValues, "!")
|
|
254
|
+
|
|
255
|
+
ShtName = Params(0) 'シート名
|
|
256
|
+
|
|
257
|
+
RngStr = Params(1) 'データ範囲
|
|
258
|
+
|
|
259
|
+
|
|
260
|
+
|
|
261
|
+
'データ範囲のチェック
|
|
262
|
+
|
|
263
|
+
With WBk.Worksheets.Item(ShtName)
|
|
264
|
+
|
|
265
|
+
Set Rng = .Range(RngStr)
|
|
266
|
+
|
|
267
|
+
Set NewRng = .Range(.Cells(Rng.Row, Rng.Column), .Cells(Rng.Row, Rng.End(xlToRight).Column))
|
|
268
|
+
|
|
269
|
+
NewColumnCnt = NewRng.Columns.Count
|
|
270
|
+
|
|
271
|
+
NewSrsValues = ShtName + "!" + NewRng.Address
|
|
272
|
+
|
|
273
|
+
End With
|
|
274
|
+
|
|
275
|
+
|
|
276
|
+
|
|
277
|
+
Else
|
|
278
|
+
|
|
279
|
+
'第3引数に!が存在しなかった
|
|
280
|
+
|
|
281
|
+
NewSrsValues = SrsValues
|
|
282
|
+
|
|
283
|
+
End If
|
|
284
|
+
|
|
285
|
+
|
|
286
|
+
|
|
287
|
+
'現在のデータ範囲とチェックによって決定されたデータ範囲を比較
|
|
288
|
+
|
|
289
|
+
If SrsValues = NewSrsValues Then
|
|
290
|
+
|
|
291
|
+
'一致した場合は次の系列へ
|
|
292
|
+
|
|
293
|
+
Debug.Print " > データ範囲の変更は行われませんでした"
|
|
294
|
+
|
|
295
|
+
GoTo CONTINUE_FOR
|
|
296
|
+
|
|
297
|
+
End If
|
|
298
|
+
|
|
299
|
+
|
|
300
|
+
|
|
301
|
+
'-----------------------------------------
|
|
302
|
+
|
|
303
|
+
'SERIESの第2引数(項目軸のラベル)をチェック
|
|
304
|
+
|
|
305
|
+
'-----------------------------------------
|
|
306
|
+
|
|
307
|
+
If InStr(SrsLabels, "!") > 0 Then
|
|
308
|
+
|
|
309
|
+
Params = Split(SrsLabels, "!")
|
|
310
|
+
|
|
311
|
+
ShtName = Params(0) 'シート名
|
|
312
|
+
|
|
313
|
+
RngStr = Params(1) 'ラベル範囲
|
|
314
|
+
|
|
315
|
+
|
|
316
|
+
|
|
317
|
+
'ラベルの範囲を決定
|
|
318
|
+
|
|
319
|
+
With WBk.Worksheets.Item(ShtName)
|
|
320
|
+
|
|
321
|
+
Set Rng = .Range(RngStr)
|
|
322
|
+
|
|
323
|
+
Set NewRng = .Range(.Cells(Rng.Row, Rng.Column), .Cells(Rng.Row, Rng.Column + NewColumnCnt - 1))
|
|
324
|
+
|
|
325
|
+
NewSrsLabels = ShtName + "!" + NewRng.Address
|
|
326
|
+
|
|
327
|
+
End With
|
|
328
|
+
|
|
329
|
+
|
|
330
|
+
|
|
331
|
+
Else
|
|
332
|
+
|
|
333
|
+
'第2引数に!が存在しなかった
|
|
334
|
+
|
|
335
|
+
NewSrsLabels = SrsLabels
|
|
336
|
+
|
|
337
|
+
End If
|
|
338
|
+
|
|
339
|
+
|
|
340
|
+
|
|
341
|
+
'新しくFormulaに設定する文字列を生成
|
|
342
|
+
|
|
343
|
+
NewFormula = "=SERIES(" & SrsName & "," & NewSrsLabels & "," & NewSrsValues & "," & SrsOrder & ")"
|
|
344
|
+
|
|
345
|
+
|
|
346
|
+
|
|
347
|
+
Debug.Print Chr(10) & " [Formula]"
|
|
348
|
+
|
|
349
|
+
Debug.Print " " & FormulaValue
|
|
350
|
+
|
|
351
|
+
Debug.Print " " & NewFormula
|
|
352
|
+
|
|
353
|
+
|
|
354
|
+
|
|
355
|
+
'生成したFormulaの値を系列に適用
|
|
356
|
+
|
|
357
|
+
Srs.Formula = NewFormula
|
|
358
|
+
|
|
359
|
+
|
|
360
|
+
|
|
361
|
+
CONTINUE_FOR:
|
|
362
|
+
|
|
363
|
+
If Err.Number <> 0 Then Exit Function
|
|
364
|
+
|
|
365
|
+
|
|
366
|
+
|
|
367
|
+
Next SrsIdx
|
|
368
|
+
|
|
369
|
+
|
|
370
|
+
|
|
371
|
+
Debug.Print Chr(10) & "> 正常に終了しました" & Chr(10)
|
|
372
|
+
|
|
373
|
+
|
|
374
|
+
|
|
375
|
+
DataRangeChecker = True
|
|
376
|
+
|
|
377
|
+
|
|
378
|
+
|
|
379
|
+
End Function
|
|
380
|
+
|
|
381
|
+
```
|
|
382
|
+
|
|
383
|
+
・データ範囲内に歯抜けが存在する事を想定していない(あいだに空のセルが入らない)
|
|
384
|
+
|
|
385
|
+
・プロットする系列のデータは横(列)方向に並んでいる
|
|
386
|
+
|
|
387
|
+
・末尾(右端)側の適切でない範囲を修正するのみで先頭(左端)側の修正はしない
|
|
388
|
+
|
|
389
|
+
・データ範囲の指定が連続していて"とびとび(不連続)"の指示を想定していない
|
|
390
|
+
|
|
391
|
+
・ブックを跨いだデータ範囲の指定が存在しない(回避策はあり)
|
|
392
|
+
|
|
393
|
+
などの前提になっていますので、この前提で問題があるようでしたら教えてください。
|
|
394
|
+
|
|
395
|
+
# 4番目の「連続でない」状況があると結構やっかいになりますが、他はそんなに難易度高くないです。
|
|
396
|
+
|
|
397
|
+
|
|
398
|
+
|
|
399
|
+
一応、質問文中で頂いているコードの中から呼び出せるように「引数で指定された単一のグラフについて処理をする」機能として関数化しました。
|
|
400
|
+
|
|
401
|
+
|
|
402
|
+
|
|
403
|
+
以下のように書いてあげれば、変更処理の前にデータ範囲の修正ができます。
|
|
404
|
+
|
|
405
|
+
**DataRangeChecker(<グラフの存在するワークブック>, <対象とするグラフ>)**
|
|
406
|
+
|
|
407
|
+
```VBA
|
|
408
|
+
|
|
409
|
+
Sub graph_change()
|
|
410
|
+
|
|
411
|
+
'省略
|
|
412
|
+
|
|
413
|
+
For j = 1 To ws.ChartObjects.Count
|
|
414
|
+
|
|
415
|
+
|
|
416
|
+
|
|
417
|
+
'正常に処理を完了したか?をTrue/Falseで返すように作りましたが、
|
|
418
|
+
|
|
419
|
+
'戻り値が不要であれば、コメント側のようにCallで呼んでもらっても良いと思います。
|
|
420
|
+
|
|
421
|
+
ret = DataRangeChecker(wb, ws.ChartObjects(j)) ' <--------------------------
|
|
422
|
+
|
|
423
|
+
'Call DataRangeChecker(wb, ws.ChartObjects(j))
|
|
424
|
+
|
|
425
|
+
|
|
426
|
+
|
|
427
|
+
With ws.ChartObjects(j).Chart
|
|
428
|
+
|
|
429
|
+
'省略
|
|
430
|
+
|
|
431
|
+
```
|
|
432
|
+
|
|
433
|
+
|
|
434
|
+
|
|
435
|
+
大量にDebug.Printを入れてますが、確認用です。最終的なコードからは該当行を削除してもらって構いません。
|
|
436
|
+
|
|
437
|
+
|
|
438
|
+
|
|
439
|
+
コードの実行前と実行後のスクリーンショットを貼り付けておきます。
|
|
440
|
+
|
|
441
|
+
[実行前]
|
|
442
|
+
|
|
443
|
+
|
|
444
|
+
|
|
445
|
+
|
|
446
|
+
|
|
447
|
+
[実行後]
|
|
448
|
+
|
|
449
|
+
|
|
450
|
+
|
|
451
|
+
|