質問編集履歴

1

ソースコードの範囲拡大、エラー説明追加

2020/04/03 02:24

投稿

kingkamehameha
kingkamehameha

スコア16

test CHANGED
File without changes
test CHANGED
@@ -24,7 +24,21 @@
24
24
 
25
25
  ### エラーが起きるコード
26
26
 
27
+ ActiveWorkbook.SaveAs FileName:=Foldername & "\" & TName & "_" & Month & "月分.xlsx", FileFormat:=xlWorkbookDefault, Local:=True
28
+
29
+
30
+
31
+ ### エラー内容
32
+
33
+ リモートサーバーがないか、使用できる状態ではありません。
34
+
35
+
36
+
37
+ ## エラー出現タイミング
38
+
39
+ 初回実行時、エラーが出た後VBEから中断、再度実行すると作成できる。
40
+
27
- WbObj.Sheets("テンプレート").Copy After:=SaveWbObj.Worksheets(1)
41
+ 作成ファイルを開くと元のテンプレート.xlsxの回復ウィンドウが表示される。
28
42
 
29
43
 
30
44
 
@@ -32,41 +46,483 @@
32
46
 
33
47
  ・WbObj/SaveWbObjをVariantにしたりWorkBook などにしたりしてみた
34
48
 
35
- ・Sleep xxxxを入れてWbObjがセットされるまで、次の処理を待たせた
36
-
37
-
38
-
39
-
40
-
41
-
42
-
43
- ```ここに言語を入力
44
-
45
- ~略~
46
-
47
- Dim AppObj As Object 'EXCELアプリケーション
48
-
49
- Static WbObj As Workbook 'テンプレート
50
-
51
- Dim WsObj As Object '保存シート
52
-
53
- Static SaveWbObj As Object '保存ブック
54
-
55
- Dim Item As Variant '配列取出用
56
-
57
- Dim j As Long: j = 1 'シート名重複
58
-
59
- Dim CNameStr As String '顧客コード整形用
60
-
61
- Static i As Long '取引先の数
62
-
63
- Static column As Long '横列
64
-
65
- Static rows As Long '縦行
66
-
67
- Static CompanyCnt As Long '取引先数
68
-
69
- Static flg As Boolean '初回用
49
+ ・Sleep xxxxを入れてWbObjがセットされるまで、次の処理を待たせたりしたけどダメだった。
50
+
51
+
52
+
53
+ ```Form[CODE_LINK]
54
+
55
+ DOption Compare Database
56
+
57
+ Option Explicit
58
+
59
+
60
+
61
+ Private Sub 作成開始_Click()
62
+
63
+
64
+
65
+ '処理の確認
66
+
67
+ Dim chk As Integer
68
+
69
+ chk = MsgBox("処理を開始してよろしいですか?", vbYesNo + vbQuestion, "確認")
70
+
71
+ DoCmd.OpenForm "NOW_PROCESSING"
72
+
73
+ If chk = vbYes Then
74
+
75
+
76
+
77
+
78
+
79
+
80
+
81
+ '=========================担当者の抽出===========================
82
+
83
+
84
+
85
+ 'cntが担当者数、TNArrayが担当者コード(昇順)
86
+
87
+
88
+
89
+ Dim db As Database
90
+
91
+ Dim RS As Recordset
92
+
93
+ Dim SQL As String
94
+
95
+ Dim i As Long: i = 0
96
+
97
+ Dim Cnt As Long
98
+
99
+ Dim TCArray() As Variant
100
+
101
+ Dim TNArray() As Variant
102
+
103
+
104
+
105
+ SQL = "SELECT DISTINCT 利益一覧.担当者コード,利益一覧.担当者名 FROM 利益一覧 ORDER BY 利益一覧.担当者コード;"
106
+
107
+
108
+
109
+ Set db = CurrentDb
110
+
111
+ Set RS = db.OpenRecordset(SQL, dbOpenSnapshot)
112
+
113
+ Cnt = RS.RecordCount
114
+
115
+ ReDim TNArray(Cnt)
116
+
117
+ ReDim TCArray(Cnt)
118
+
119
+
120
+
121
+
122
+
123
+ Do Until RS.EOF
124
+
125
+ TCArray(i) = RS!担当者コード
126
+
127
+ TNArray(i) = RS!担当者名
128
+
129
+ ''Debug.Print "TCArray(" & i & ")" & RS!担当者コード & " " & "TNArray(" & i; ")" & RS!担当者名
130
+
131
+ RS.MoveNext
132
+
133
+ i = i + 1
134
+
135
+ Loop
136
+
137
+ Call DBexport(db, RS)
138
+
139
+
140
+
141
+ '=========================担当者毎に取引先抽出===========================
142
+
143
+
144
+
145
+ Dim AppObj As Excel.Application
146
+
147
+ Dim WbObj As Excel.Workbook
148
+
149
+
150
+
151
+ Dim TName As String '担当者名 TNArrayの担当者コードを基に抽出
152
+
153
+ Dim Month As String '算出月
154
+
155
+ Dim arMod(2) As Long '月算出用
156
+
157
+ Dim CCArray() As Variant '取引先コード
158
+
159
+ Dim CNArray() As Variant '取引先名一覧
160
+
161
+ Dim CName As String '顧客名
162
+
163
+ Dim check As Long '取引先の処理カウント cntと一緒になったら次の担当者へ
164
+
165
+ Dim Sales As Long '売上(+)
166
+
167
+ Dim PurChase As Long '仕入値(-)
168
+
169
+ Dim Revate As Long 'リベート(+)
170
+
171
+ Dim GP As Long '売上総利益(粗利益) GrossProfit
172
+
173
+ Dim GPM As Double '粗利率(%) GrossProfitMargin
174
+
175
+ Dim DF As Long 'EMS(-) EMS
176
+
177
+ Dim DFCnt As Long 'EMSの項目数
178
+
179
+ Dim DFArray() As Variant 'EMSの項目格納用
180
+
181
+ Dim HITDF() As Variant 'EMSの項目格納用(該当諸掛のみ)
182
+
183
+ Dim DHL As Long 'DHL(-) DHL
184
+
185
+ Dim DHLCnt As Long 'DHLの項目数
186
+
187
+ Dim DHLArray() As Variant 'DHLの項目格納用
188
+
189
+ Dim HITDHL() As Variant 'DHLの項目格納用(該当諸掛のみ)
190
+
191
+ Dim WP As Long 'その他
192
+
193
+ Dim WPCnt As Long 'ろう見本代の項目数
194
+
195
+ Dim WPArray() As Variant 'ろう見本代の項目格納用
196
+
197
+ Dim HITWP() As Variant 'ろう見本の項目格納用(該当諸掛のみ)
198
+
199
+ Dim TP As Long '輸出利益(経費引当後) Trade Profit
200
+
201
+ Dim TPM As Double '輸出利益率(経費引当後) TradeProfitMargin
202
+
203
+ Dim j As Long: j = 0
204
+
205
+ Dim k As Long: k = 0
206
+
207
+ Dim l As Long: l = 0 '項目HIT数
208
+
209
+ Dim m As Long: m = 0 'HIT項目収納カウント数
210
+
211
+ Dim RC As Long '得意先別のレコード数(計算に利用)
212
+
213
+ Dim flg As Boolean 'リベート項目があるかチェックするフラグ
214
+
215
+ Dim Item As Variant '配列からForeachで取出用
216
+
217
+
218
+
219
+
220
+
221
+ 中略
222
+
223
+
224
+
225
+
226
+
227
+ k = k + 1
228
+
229
+ 'j = j + 1
230
+
231
+ check = check + 1
232
+
233
+
234
+
235
+ 'ファイル作成プログラムに投げる
236
+
237
+ Call FileMaker(Foldername, Cnt, TName, Month, CName, Sales, PurChase, Revate, Lavel, IP, GP, GPM, EFC, CF, DF, DHL, SF, SP, WP, TP, TPM, HITScode(), HITIP(), HITEFC(), HITCF(), HITDF(), HITDHL(), HITSF(), HITSP(), HITWP(), EFCArray(), CFArray(), DFArray(), DHLArray(), SFArray(), CCArray(), TCArray(), SPArray(), WPArray(), AppObj, WbObj)
238
+
239
+ Loop
240
+
241
+
242
+
243
+ '変数の初期化
244
+
245
+ k = 0
246
+
247
+ j = 0
248
+
249
+ check = 0
250
+
251
+
252
+
253
+ Next i
254
+
255
+
256
+
257
+ '処理中フォームの非表示
258
+
259
+ DoCmd.Close acForm, "NOW_PROCESSING"
260
+
261
+
262
+
263
+ 'AppObj.Quit
264
+
265
+ Set AppObj = Nothing
266
+
267
+
268
+
269
+ '作成フォルダを開く
270
+
271
+ Dim rc2 As Integer
272
+
273
+ rc2 = MsgBox("処理が完了しました。ファイルを確認しますか?", vbYesNo + vbQuestion, "確認")
274
+
275
+ If rc2 = vbYes Then
276
+
277
+ Shell "C:\Windows\Explorer.exe " & Foldername, vbNormalFocus
278
+
279
+ Call ExcelKill
280
+
281
+ End If
282
+
283
+
284
+
285
+
286
+
287
+ '処理の確認=False
288
+
289
+ Else
290
+
291
+
292
+
293
+ Exit Sub
294
+
295
+
296
+
297
+ End If
298
+
299
+ End Sub
300
+
301
+
302
+
303
+ 'データーベースとレコードセット開放
304
+
305
+ Private Sub DBexport(db As Database, RS As Recordset)
306
+
307
+
308
+
309
+ RS.Close
310
+
311
+ db.Close
312
+
313
+ Set db = Nothing
314
+
315
+ Set RS = Nothing
316
+
317
+
318
+
319
+ End Sub
320
+
321
+
322
+
323
+ 'データベースとレコードセットの登録
324
+
325
+ Private Sub DBSet(db As Database, RS As Recordset, SQL As String)
326
+
327
+
328
+
329
+ Set db = CurrentDb
330
+
331
+ Set RS = db.OpenRecordset(SQL, dbOpenSnapshot)
332
+
333
+
334
+
335
+ End Sub
336
+
337
+
338
+
339
+ '配列内の重複値削除用
340
+
341
+ Function DeleteSameValue(ar() As Variant) As Variant
342
+
343
+ Dim i '// ループカウンタ1
344
+
345
+ Dim ii '// ループカウンタ2
346
+
347
+ Dim iLen '// 配列要素数
348
+
349
+ Dim arEdit() '// 編集後の配列
350
+
351
+ Dim iEdit '// 編集後配列のインデックス
352
+
353
+ Dim flg As Boolean '// 重複有無判定フラグ(True:重複あり、False:なし)
354
+
355
+
356
+
357
+ If IsArrayEx(ar()) = 1 Then
358
+
359
+ ReDim arEdit(0)
360
+
361
+ iLen = UBound(ar)
362
+
363
+
364
+
365
+ '// 配列ループ
366
+
367
+ For i = 0 To iLen
368
+
369
+ '// 重複有無判定フラグを重複なしとして初期化
370
+
371
+ flg = False
372
+
373
+
374
+
375
+ '// 重複除去済みの編集後配列ループ
376
+
377
+ For iEdit = 0 To UBound(arEdit)
378
+
379
+ '// 編集後配列に格納済みの場合
380
+
381
+ If (ar(i) = arEdit(iEdit)) Then
382
+
383
+ flg = True
384
+
385
+ Exit For
386
+
387
+ End If
388
+
389
+ Next
390
+
391
+
392
+
393
+ '// 現ループの値には重複がない場合
394
+
395
+ If (flg = False) Then
396
+
397
+ '// 重複がない値のみを編集後配列に格納する
398
+
399
+ arEdit(UBound(arEdit)) = ar(i)
400
+
401
+ ReDim Preserve arEdit(UBound(arEdit) + 1)
402
+
403
+ End If
404
+
405
+ Next
406
+
407
+
408
+
409
+ '// 配列に格納済みの場合
410
+
411
+ If (IsEmpty(arEdit(0)) = False) Then
412
+
413
+ '// 余分な領域を削除
414
+
415
+ ReDim Preserve arEdit(UBound(arEdit) - 1)
416
+
417
+ End If
418
+
419
+
420
+
421
+ '// 引数に編集後配列を設定
422
+
423
+ ar = arEdit
424
+
425
+ Else
426
+
427
+ End If
428
+
429
+ End Function
430
+
431
+
432
+
433
+ '***********************************************************
434
+
435
+ ' 機能 : 引数が配列か判定し、配列の場合は空かどうかも判定する
436
+
437
+ ' 引数 : varArray 配列
438
+
439
+ ' 戻り値 : 判定結果(1:配列/0:空の配列/-1:配列じゃない)
440
+
441
+ '***********************************************************
442
+
443
+ Public Function IsArrayEx(varArray As Variant) As Long
444
+
445
+ On Error GoTo ERROR_
446
+
447
+
448
+
449
+ If IsArray(varArray) Then
450
+
451
+ IsArrayEx = IIf(UBound(varArray) >= 0, 1, 0)
452
+
453
+ Else
454
+
455
+ IsArrayEx = -1
456
+
457
+ End If
458
+
459
+
460
+
461
+ Exit Function
462
+
463
+
464
+
465
+ ERROR_:
466
+
467
+ If Err.Number = 9 Then
468
+
469
+ IsArrayEx = 0
470
+
471
+ End If
472
+
473
+ End Function
474
+
475
+
476
+
477
+ ```
478
+
479
+ ```FilaMaker
480
+
481
+ Option Compare Database
482
+
483
+ Option Explicit
484
+
485
+ Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
486
+
487
+ Rem ----------------------------------------------------------------------------------
488
+
489
+ Rem 関数名 : FileMaker
490
+
491
+ Rem 処理内容 : 担当者毎の取引先シート別EXCELファイル作成
492
+
493
+ Rem 引 数  :
494
+
495
+ Rem 戻り値  : 無
496
+
497
+ Rem メ モ  : 'Form_CODE_LINKから項目名を受け取りEXCELファイル作成←配列渡しのがスマートかも?課題
498
+
499
+ Rem ----------------------------------------------------------------------------------
500
+
501
+ Function FileMaker(Foldername As String, Cnt As Long, TName As String, Month As String, CName As String, Sales As Long, PurChase As Long, Revate As Long, Lavel As Long, IP As Long, GP As Long, GPM As Double, EFC As Long, CF As Long, DF As Long, DHL As Long, SF As Long, SP As Long, WP As Long, TP As Long, TPM As Double, HITScode() As Variant, HITIP() As Variant, HITEFC() As Variant, HITCF() As Variant, HITIDF() As Variant, HITDHL() As Variant, HITSF() As Variant, HITSP() As Variant, HITWP() As Variant, EFCArray() As Variant, CFArray() As Variant, DFArray() As Variant, SFArray() As Variant, DHLArray() As Variant, CCArray() As Variant, TCArray() As Variant, SPArray() As Variant, WPArray() As Variant, AppObj As Excel.Application, WbObj As Excel.Workbook)
502
+
503
+
504
+
505
+
506
+
507
+ Dim WsObj As Excel.Worksheet '保存シート
508
+
509
+ Static SaveWbObj As Excel.Workbook '保存ブック
510
+
511
+ Dim Item As Variant '配列取出用
512
+
513
+ Dim j As Long: j = 1 'シート名重複
514
+
515
+ Dim CNameStr As String '顧客コード整形用
516
+
517
+ Static i As Long '取引先の数
518
+
519
+ Static column As Long '横列
520
+
521
+ Static rows As Long '縦行
522
+
523
+ Static CompanyCnt As Long '取引先数
524
+
525
+ Static flg As Boolean '初回用
70
526
 
71
527
 
72
528
 
@@ -74,14 +530,16 @@
74
530
 
75
531
  'Call ExcelKill
76
532
 
77
- Set AppObj = CreateObject("Excel.Application")
533
+ ' Set AppObj = CreateObject("Excel.Application")
78
-
534
+
79
- Set WbObj = AppObj.Workbooks.Open(Application.CurrentProject.Path & "\【削除不可】利益算出表テンプレート.xlsx")
535
+ ' Set WbObj = AppObj.Workbooks.Open(Application.CurrentProject.Path & "\【削除不可】利益算出表テンプレート.xlsx")
80
536
 
81
537
  AppObj.Visible = False
82
538
 
83
539
  flg = True
84
540
 
541
+ Sleep 1000
542
+
85
543
 
86
544
 
87
545
  End If
@@ -96,20 +554,106 @@
96
554
 
97
555
  rows = 5
98
556
 
557
+ Sleep 1000
558
+
99
- Set SaveWbObj = Workbooks.Add
559
+ Set SaveWbObj = AppObj.Workbooks.Add(1)
560
+
561
+ Debug.Print AppObj
562
+
563
+ 'Debug.Print WbObj
100
564
 
101
565
  End If
102
566
 
103
- 'Sleep 2000
567
+ Sleep 1000
104
-
568
+
105
- 'With オブジェクト変数が設定されていません。または、Copyに失敗しました。エラー表示され
569
+ 'With オブジェクト変数が設定されていません。エラーがたまにで
106
570
 
107
571
  WbObj.Sheets("テンプレート").Copy After:=SaveWbObj.Worksheets(1)
108
572
 
109
- Set WsObj = ActiveSheet
573
+ Set WsObj = SaveWbObj.ActiveSheet
574
+
575
+
576
+
110
-
577
+ If SaveWbObj.Sheets(1).Name = "Sheet1" Then
578
+
111
-
579
+ SaveWbObj.Sheets("Sheet1").Delete
580
+
112
-
581
+ End If
582
+
583
+ 'Set SaveWbObj = ActiveWorkbook
584
+
585
+
586
+
587
+ WsObj.Range("B2").Value = TName
588
+
589
+ WsObj.Range("B3").Value = Month
590
+
591
+
592
+
113
- 以下省
593
+
594
+
595
+
596
+
597
+
598
+
114
-
599
+ '書出位置初期化
600
+
601
+ column = 2
602
+
603
+ rows = 5
604
+
605
+
606
+
607
+
608
+
609
+ CNameStr = Left(CCArray(i) & "_" & CName, 31)
610
+
611
+ SaveWbObj.ActiveSheet.Name = CNameStr
612
+
613
+ i = i + 1
614
+
615
+ If CompanyCnt = i Then
616
+
617
+
618
+
115
- ```
619
+ i = 0
620
+
621
+ j = 0
622
+
623
+ '終了時にファイルの保存
624
+
625
+ AppObj.Application.DisplayAlerts = False
626
+
627
+ SaveWbObj.Sheets(1).Select
628
+
629
+ ActiveWorkbook.SaveAs FileName:=Foldername & "\" & TName & "_" & Month & "月分.xlsx", FileFormat:=xlWorkbookDefault, Local:=True
630
+
631
+ SaveWbObj.Close
632
+
633
+ Set SaveWbObj = Nothing
634
+
635
+ AppObj.Application.DisplayAlerts = True
636
+
637
+
638
+
639
+ If TName = "TRAN MINH DUC" And i = 0 Then
640
+
641
+ WbObj.Close SaveChanges:=False
642
+
643
+ Sleep 1000
644
+
645
+ AppObj.Quit
646
+
647
+ Set AppObj = Nothing
648
+
649
+ Set WbObj = Nothing
650
+
651
+ 'Call ExcelKill
652
+
653
+ End If
654
+
655
+
656
+
657
+ End If
658
+
659
+ End Function