質問編集履歴
1
ソースコードの範囲拡大、エラー説明追加
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -11,35 +11,264 @@
|
|
|
11
11
|
前の処理の流れで、Excelが残っているとエラーの原因になるのでWScript.shellにexecでEXCEL.EXEをキルしています。
|
|
12
12
|
|
|
13
13
|
### エラーが起きるコード
|
|
14
|
-
|
|
14
|
+
ActiveWorkbook.SaveAs FileName:=Foldername & "\" & TName & "_" & Month & "月分.xlsx", FileFormat:=xlWorkbookDefault, Local:=True
|
|
15
15
|
|
|
16
|
+
### エラー内容
|
|
17
|
+
リモートサーバーがないか、使用できる状態ではありません。
|
|
18
|
+
|
|
19
|
+
## エラー出現タイミング
|
|
20
|
+
初回実行時、エラーが出た後VBEから中断、再度実行すると作成できる。
|
|
21
|
+
作成ファイルを開くと元のテンプレート.xlsxの回復ウィンドウが表示される。
|
|
22
|
+
|
|
16
23
|
### 試したこと
|
|
17
24
|
・WbObj/SaveWbObjをVariantにしたりWorkBook などにしたりしてみた
|
|
18
|
-
・Sleep xxxxを入れてWbObjがセットされるまで、次の処理を待たせた
|
|
25
|
+
・Sleep xxxxを入れてWbObjがセットされるまで、次の処理を待たせたりしたけどダメだった。
|
|
19
26
|
|
|
27
|
+
```Form[CODE_LINK]
|
|
28
|
+
DOption Compare Database
|
|
29
|
+
Option Explicit
|
|
20
30
|
|
|
31
|
+
Private Sub 作成開始_Click()
|
|
21
32
|
|
|
22
|
-
|
|
33
|
+
'処理の確認
|
|
23
|
-
～略～
|
|
24
|
-
Dim AppObj As Object 'EXCELアプリケーション
|
|
25
|
-
Static WbObj As Workbook 'テンプレート
|
|
26
|
-
Dim WsObj As Object '保存シート
|
|
27
|
-
Static SaveWbObj As Object '保存ブック
|
|
28
|
-
Dim
|
|
34
|
+
Dim chk As Integer
|
|
35
|
+
chk = MsgBox("処理を開始してよろしいですか？", vbYesNo + vbQuestion, "確認")
|
|
29
|
-
|
|
36
|
+
DoCmd.OpenForm "NOW_PROCESSING"
|
|
30
|
-
Dim CNameStr As String '顧客コード整形用
|
|
31
|
-
Static i As Long '取引先の数
|
|
32
|
-
|
|
37
|
+
If chk = vbYes Then
|
|
33
|
-
|
|
38
|
+
|
|
34
|
-
Static CompanyCnt As Long '取引先数
|
|
35
|
-
Static flg As Boolean '初回用
|
|
36
39
|
|
|
40
|
+
|
|
41
|
+
'=========================担当者の抽出===========================
|
|
42
|
+
|
|
43
|
+
'cntが担当者数、TNArrayが担当者コード(昇順)
|
|
44
|
+
|
|
45
|
+
Dim db As Database
|
|
46
|
+
Dim RS As Recordset
|
|
47
|
+
Dim SQL As String
|
|
48
|
+
Dim i As Long: i = 0
|
|
49
|
+
Dim Cnt As Long
|
|
50
|
+
Dim TCArray() As Variant
|
|
51
|
+
Dim TNArray() As Variant
|
|
52
|
+
|
|
53
|
+
SQL = "SELECT DISTINCT 利益一覧.担当者コード,利益一覧.担当者名 FROM 利益一覧 ORDER BY 利益一覧.担当者コード;"
|
|
54
|
+
|
|
55
|
+
Set db = CurrentDb
|
|
56
|
+
Set RS = db.OpenRecordset(SQL, dbOpenSnapshot)
|
|
57
|
+
Cnt = RS.RecordCount
|
|
58
|
+
ReDim TNArray(Cnt)
|
|
59
|
+
ReDim TCArray(Cnt)
|
|
60
|
+
|
|
61
|
+
|
|
62
|
+
Do Until RS.EOF
|
|
63
|
+
TCArray(i) = RS!担当者コード
|
|
64
|
+
TNArray(i) = RS!担当者名
|
|
65
|
+
''Debug.Print "TCArray(" & i & ")" & RS!担当者コード & " " & "TNArray(" & i; ")" & RS!担当者名
|
|
66
|
+
RS.MoveNext
|
|
67
|
+
i = i + 1
|
|
68
|
+
Loop
|
|
69
|
+
Call DBexport(db, RS)
|
|
70
|
+
|
|
71
|
+
'=========================担当者毎に取引先抽出===========================
|
|
72
|
+
|
|
73
|
+
Dim AppObj As Excel.Application
|
|
74
|
+
Dim WbObj As Excel.Workbook
|
|
75
|
+
|
|
76
|
+
Dim TName As String '担当者名 TNArrayの担当者コードを基に抽出
|
|
77
|
+
Dim Month As String '算出月
|
|
78
|
+
Dim arMod(2) As Long '月算出用
|
|
79
|
+
Dim CCArray() As Variant '取引先コード
|
|
80
|
+
Dim CNArray() As Variant '取引先名一覧
|
|
81
|
+
Dim CName As String '顧客名
|
|
82
|
+
Dim check As Long '取引先の処理カウント cntと一緒になったら次の担当者へ
|
|
83
|
+
Dim Sales As Long '売上(+)
|
|
84
|
+
Dim PurChase As Long '仕入値(-)
|
|
85
|
+
Dim Revate As Long 'リベート(+)
|
|
86
|
+
Dim GP As Long '売上総利益(粗利益) GrossProfit
|
|
87
|
+
Dim GPM As Double '粗利率(%) GrossProfitMargin
|
|
88
|
+
Dim DF As Long 'EMS(-) EMS
|
|
89
|
+
Dim DFCnt As Long 'EMSの項目数
|
|
90
|
+
Dim DFArray() As Variant 'EMSの項目格納用
|
|
91
|
+
Dim HITDF() As Variant 'EMSの項目格納用(該当諸掛のみ)
|
|
92
|
+
Dim DHL As Long 'DHL(-) DHL
|
|
93
|
+
Dim DHLCnt As Long 'DHLの項目数
|
|
94
|
+
Dim DHLArray() As Variant 'DHLの項目格納用
|
|
95
|
+
Dim HITDHL() As Variant 'DHLの項目格納用(該当諸掛のみ)
|
|
96
|
+
Dim WP As Long 'その他
|
|
97
|
+
Dim WPCnt As Long 'ろう見本代の項目数
|
|
98
|
+
Dim WPArray() As Variant 'ろう見本代の項目格納用
|
|
99
|
+
Dim HITWP() As Variant 'ろう見本の項目格納用(該当諸掛のみ)
|
|
100
|
+
Dim TP As Long '輸出利益(経費引当後) Trade Profit
|
|
101
|
+
Dim TPM As Double '輸出利益率(経費引当後) TradeProfitMargin
|
|
102
|
+
Dim j As Long: j = 0
|
|
103
|
+
Dim k As Long: k = 0
|
|
104
|
+
Dim l As Long: l = 0 '項目HIT数
|
|
105
|
+
Dim m As Long: m = 0 'HIT項目収納カウント数
|
|
106
|
+
Dim RC As Long '得意先別のレコード数(計算に利用)
|
|
107
|
+
Dim flg As Boolean 'リベート項目があるかチェックするフラグ
|
|
108
|
+
Dim Item As Variant '配列からForeachで取出用
|
|
109
|
+
|
|
110
|
+
|
|
111
|
+
中略
|
|
112
|
+
|
|
113
|
+
|
|
114
|
+
k = k + 1
|
|
115
|
+
'j = j + 1
|
|
116
|
+
check = check + 1
|
|
117
|
+
|
|
118
|
+
'ファイル作成プログラムに投げる
|
|
119
|
+
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)
|
|
120
|
+
Loop
|
|
121
|
+
|
|
122
|
+
'変数の初期化
|
|
123
|
+
k = 0
|
|
124
|
+
j = 0
|
|
125
|
+
check = 0
|
|
126
|
+
|
|
127
|
+
Next i
|
|
128
|
+
|
|
129
|
+
'処理中フォームの非表示
|
|
130
|
+
DoCmd.Close acForm, "NOW_PROCESSING"
|
|
131
|
+
|
|
132
|
+
'AppObj.Quit
|
|
133
|
+
Set AppObj = Nothing
|
|
134
|
+
|
|
135
|
+
'作成フォルダを開く
|
|
136
|
+
Dim rc2 As Integer
|
|
137
|
+
rc2 = MsgBox("処理が完了しました。ファイルを確認しますか？", vbYesNo + vbQuestion, "確認")
|
|
138
|
+
If rc2 = vbYes Then
|
|
139
|
+
Shell "C:\Windows\Explorer.exe " & Foldername, vbNormalFocus
|
|
140
|
+
Call ExcelKill
|
|
141
|
+
End If
|
|
142
|
+
|
|
143
|
+
|
|
144
|
+
'処理の確認=False
|
|
145
|
+
Else
|
|
146
|
+
|
|
147
|
+
Exit Sub
|
|
148
|
+
|
|
149
|
+
End If
|
|
150
|
+
End Sub
|
|
151
|
+
|
|
152
|
+
'データーベースとレコードセット開放
|
|
153
|
+
Private Sub DBexport(db As Database, RS As Recordset)
|
|
154
|
+
|
|
155
|
+
RS.Close
|
|
156
|
+
db.Close
|
|
157
|
+
Set db = Nothing
|
|
158
|
+
Set RS = Nothing
|
|
159
|
+
|
|
160
|
+
End Sub
|
|
161
|
+
|
|
162
|
+
'データベースとレコードセットの登録
|
|
163
|
+
Private Sub DBSet(db As Database, RS As Recordset, SQL As String)
|
|
164
|
+
|
|
165
|
+
Set db = CurrentDb
|
|
166
|
+
Set RS = db.OpenRecordset(SQL, dbOpenSnapshot)
|
|
167
|
+
|
|
168
|
+
End Sub
|
|
169
|
+
|
|
170
|
+
'配列内の重複値削除用
|
|
171
|
+
Function DeleteSameValue(ar() As Variant) As Variant
|
|
172
|
+
Dim i '// ループカウンタ１
|
|
173
|
+
Dim ii '// ループカウンタ２
|
|
174
|
+
Dim iLen '// 配列要素数
|
|
175
|
+
Dim arEdit() '// 編集後の配列
|
|
176
|
+
Dim iEdit '// 編集後配列のインデックス
|
|
177
|
+
Dim flg As Boolean '// 重複有無判定フラグ（True：重複あり、False：なし）
|
|
178
|
+
|
|
179
|
+
If IsArrayEx(ar()) = 1 Then
|
|
180
|
+
ReDim arEdit(0)
|
|
181
|
+
iLen = UBound(ar)
|
|
182
|
+
|
|
183
|
+
'// 配列ループ
|
|
184
|
+
For i = 0 To iLen
|
|
185
|
+
'// 重複有無判定フラグを重複なしとして初期化
|
|
186
|
+
flg = False
|
|
187
|
+
|
|
188
|
+
'// 重複除去済みの編集後配列ループ
|
|
189
|
+
For iEdit = 0 To UBound(arEdit)
|
|
190
|
+
'// 編集後配列に格納済みの場合
|
|
191
|
+
If (ar(i) = arEdit(iEdit)) Then
|
|
192
|
+
flg = True
|
|
193
|
+
Exit For
|
|
194
|
+
End If
|
|
195
|
+
Next
|
|
196
|
+
|
|
197
|
+
'// 現ループの値には重複がない場合
|
|
198
|
+
If (flg = False) Then
|
|
199
|
+
'// 重複がない値のみを編集後配列に格納する
|
|
200
|
+
arEdit(UBound(arEdit)) = ar(i)
|
|
201
|
+
ReDim Preserve arEdit(UBound(arEdit) + 1)
|
|
202
|
+
End If
|
|
203
|
+
Next
|
|
204
|
+
|
|
205
|
+
'// 配列に格納済みの場合
|
|
206
|
+
If (IsEmpty(arEdit(0)) = False) Then
|
|
207
|
+
'// 余分な領域を削除
|
|
208
|
+
ReDim Preserve arEdit(UBound(arEdit) - 1)
|
|
209
|
+
End If
|
|
210
|
+
|
|
211
|
+
'// 引数に編集後配列を設定
|
|
212
|
+
ar = arEdit
|
|
213
|
+
Else
|
|
214
|
+
End If
|
|
215
|
+
End Function
|
|
216
|
+
|
|
217
|
+
'***********************************************************
|
|
218
|
+
' 機能 : 引数が配列か判定し、配列の場合は空かどうかも判定する
|
|
219
|
+
' 引数 : varArray 配列
|
|
220
|
+
' 戻り値 : 判定結果（1:配列/0:空の配列/-1:配列じゃない）
|
|
221
|
+
'***********************************************************
|
|
222
|
+
Public Function IsArrayEx(varArray As Variant) As Long
|
|
223
|
+
On Error GoTo ERROR_
|
|
224
|
+
|
|
225
|
+
If IsArray(varArray) Then
|
|
226
|
+
IsArrayEx = IIf(UBound(varArray) >= 0, 1, 0)
|
|
227
|
+
Else
|
|
228
|
+
IsArrayEx = -1
|
|
229
|
+
End If
|
|
230
|
+
|
|
231
|
+
Exit Function
|
|
232
|
+
|
|
233
|
+
ERROR_:
|
|
234
|
+
If Err.Number = 9 Then
|
|
235
|
+
IsArrayEx = 0
|
|
236
|
+
End If
|
|
237
|
+
End Function
|
|
238
|
+
|
|
239
|
+
```
|
|
240
|
+
```FilaMaker
|
|
241
|
+
Option Compare Database
|
|
242
|
+
Option Explicit
|
|
243
|
+
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
|
|
244
|
+
Rem ----------------------------------------------------------------------------------
|
|
245
|
+
Rem 関数名 : FileMaker
|
|
246
|
+
Rem 処理内容 : 担当者毎の取引先シート別EXCELファイル作成
|
|
247
|
+
Rem 引 数 :
|
|
248
|
+
Rem 戻り値 : 無
|
|
249
|
+
Rem メ モ : 'Form_CODE_LINKから項目名を受け取りEXCELファイル作成←配列渡しのがスマートかも？課題
|
|
250
|
+
Rem ----------------------------------------------------------------------------------
|
|
251
|
+
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)
|
|
252
|
+
|
|
253
|
+
|
|
254
|
+
Dim WsObj As Excel.Worksheet '保存シート
|
|
255
|
+
Static SaveWbObj As Excel.Workbook '保存ブック
|
|
256
|
+
Dim Item As Variant '配列取出用
|
|
257
|
+
Dim j As Long: j = 1 'シート名重複
|
|
258
|
+
Dim CNameStr As String '顧客コード整形用
|
|
259
|
+
Static i As Long '取引先の数
|
|
260
|
+
Static column As Long '横列
|
|
261
|
+
Static rows As Long '縦行
|
|
262
|
+
Static CompanyCnt As Long '取引先数
|
|
263
|
+
Static flg As Boolean '初回用
|
|
264
|
+
|
|
37
265
|
If flg = False Then
|
|
38
266
|
'Call ExcelKill
|
|
39
|
-
Set AppObj = CreateObject("Excel.Application")
|
|
267
|
+
' Set AppObj = CreateObject("Excel.Application")
|
|
40
|
-
Set WbObj = AppObj.Workbooks.Open(Application.CurrentProject.Path & "\【削除不可】利益算出表テンプレート.xlsx")
|
|
268
|
+
' Set WbObj = AppObj.Workbooks.Open(Application.CurrentProject.Path & "\【削除不可】利益算出表テンプレート.xlsx")
|
|
41
269
|
AppObj.Visible = False
|
|
42
270
|
flg = True
|
|
271
|
+
Sleep 1000
|
|
43
272
|
|
|
44
273
|
End If
|
|
45
274
|
|
|
@@ -47,12 +276,55 @@
|
|
|
47
276
|
CompanyCnt = Cnt '取引先数を受け取る
|
|
48
277
|
column = 2
|
|
49
278
|
rows = 5
|
|
279
|
+
Sleep 1000
|
|
50
|
-
Set SaveWbObj = Workbooks.Add
|
|
280
|
+
Set SaveWbObj = AppObj.Workbooks.Add(1)
|
|
281
|
+
Debug.Print AppObj
|
|
282
|
+
'Debug.Print WbObj
|
|
51
283
|
End If
|
|
52
|
-
|
|
284
|
+
Sleep 1000
|
|
53
|
-
'With オブジェクト変数が設定されていません。
|
|
285
|
+
'With オブジェクト変数が設定されていません。エラーがたまにでる
|
|
54
286
|
WbObj.Sheets("テンプレート").Copy After:=SaveWbObj.Worksheets(1)
|
|
55
|
-
Set WsObj = ActiveSheet
|
|
287
|
+
Set WsObj = SaveWbObj.ActiveSheet
|
|
288
|
+
|
|
289
|
+
If SaveWbObj.Sheets(1).Name = "Sheet1" Then
|
|
290
|
+
SaveWbObj.Sheets("Sheet1").Delete
|
|
291
|
+
End If
|
|
292
|
+
'Set SaveWbObj = ActiveWorkbook
|
|
293
|
+
|
|
294
|
+
WsObj.Range("B2").Value = TName
|
|
295
|
+
WsObj.Range("B3").Value = Month
|
|
296
|
+
|
|
297
|
+
中略
|
|
298
|
+
|
|
299
|
+
|
|
300
|
+
'書出位置初期化
|
|
301
|
+
column = 2
|
|
302
|
+
rows = 5
|
|
56
303
|
|
|
304
|
+
|
|
305
|
+
CNameStr = Left(CCArray(i) & "_" & CName, 31)
|
|
306
|
+
SaveWbObj.ActiveSheet.Name = CNameStr
|
|
307
|
+
i = i + 1
|
|
308
|
+
If CompanyCnt = i Then
|
|
309
|
+
|
|
57
|
-
|
|
310
|
+
i = 0
|
|
58
|
-
|
|
311
|
+
j = 0
|
|
312
|
+
'終了時にファイルの保存
|
|
313
|
+
AppObj.Application.DisplayAlerts = False
|
|
314
|
+
SaveWbObj.Sheets(1).Select
|
|
315
|
+
ActiveWorkbook.SaveAs FileName:=Foldername & "\" & TName & "_" & Month & "月分.xlsx", FileFormat:=xlWorkbookDefault, Local:=True
|
|
316
|
+
SaveWbObj.Close
|
|
317
|
+
Set SaveWbObj = Nothing
|
|
318
|
+
AppObj.Application.DisplayAlerts = True
|
|
319
|
+
|
|
320
|
+
If TName = "TRAN MINH DUC" And i = 0 Then
|
|
321
|
+
WbObj.Close SaveChanges:=False
|
|
322
|
+
Sleep 1000
|
|
323
|
+
AppObj.Quit
|
|
324
|
+
Set AppObj = Nothing
|
|
325
|
+
Set WbObj = Nothing
|
|
326
|
+
'Call ExcelKill
|
|
327
|
+
End If
|
|
328
|
+
|
|
329
|
+
End If
|
|
330
|
+
End Function
|