Option Explicit
Option Base 1
' ■Windowsログイン名取得API
Private Declare Function GetUserName Lib "ADVAPI32.dll" _
Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
'-----------------------------------------------------------------------------------------------------
'メイン処理
'-----------------------------------------------------------------------------------------------------
Sub ()
Dim basefilename As String 'マクロ実行ファイル名
Dim drive As String 'ドライブ名格納
Dim dr As String '読込パス格納
Dim filename(2) As String '読込ファイル名（配列）
Dim file_date(2) As String 'ファイル更新日格納
Dim link_dr As String '成形したパス
Dim w_filename As String '成形した読込ファイルフルパス格納
Dim j_year As Variant '和暦数格納
Dim w_year As Integer '西暦数格納
Dim month As Variant '月格納
Dim month2 As Integer '閏年判断で成形された日数格納
Dim month3 As Variant 'ファイル名操作用
Dim day_max As Variant '対象年の月MAX日数格納（配列）
Dim ka_n(7) As String '科名格納（配列）
Dim ka_c As Integer '科コード数
Dim tw1 As Variant '読込まれたCSVﾃﾞｰﾀの格納(文字列data)
Dim tw2 As Variant '読込まれたCSVﾃﾞｰﾀの格納(文字列data)
Dim tsw1 As Variant '成形されたCSVﾃﾞｰﾀの格納(題目＆fieldindex以外の文字列＆数値data)
Dim tsw2 As Variant '成形されたCSVﾃﾞｰﾀの格納(題目＆fieldindex以外の文字列＆数値data)
Dim table As Variant '成形されたCSVﾃﾞｰﾀの格納(引渡し用)[ﾒﾓﾘ開放有り]
Dim table_w As Variant '成形前のCSVデータの格納(引渡し用)[ﾒﾓﾘ開放有り]
Dim m As Integer '警告ボックス作業域
Dim lngREC(2) As Double 'CSV総レコード件数格納（配列）
Dim lngfil(2) As Double 'CSV総フィールド数格納（配列）
Dim y As Variant '作業領域
Dim i As Double '作業領域
Dim c As Double '作業領域
Dim objNtWork 'ネットワークドライブマウントオブジェクト
' Dim xlAPP As Application 'アプリケーションコマンド宣言
' Set xlAPP = Application 'アプリケーションコマンドセット
'科コード名読み取り
y = 0
Do While Workbooks(basefilename).Sheets("読込設定").Cells(8 + y, 1) <> Empty
y = y + 1
ka_n(y) = Trim$(Workbooks(basefilename).Sheets("読込設定").Cells(7 + y, 1))
Loop
'科コード名件数
For Each y In ka_n
ka_c = ka_c + 1
Next
' ka_c = ka_c - 1 '科コード99の排除
'-----------------------------------------------------------------------------------------------------
'CSVファイル読込＆無効データの強制有効化処理
'ファイル１とファイル２の読込
For i = 1 To 2
'ネットワークドライブのマウント
drive = drive_s & ":"
Set objNtWork = CreateObject("WScript.Network") 'ネットワークドライブをマウントします
If drive_m1(objNtWork, drive, link_dr) = False Then
If drive_m2(objNtWork, drive, link_dr) = False Then
objNtWork.MapNetworkDrive drive, link_dr
' objNtWork.MapNetworkDrive drive, link_dr, , "administrator1", "office.f"
End If
End If
'ファイルオープン＆成形(文字列として格納)
w_filename = dr & "\" & filename(i)
Select Case f_Open(w_filename, filename(i))
Case True
file_date(i) = FileDateTime(w_filename)
table_w = READ_TextFile(w_filename, lngREC(i), lngfil(i))
objNtWork.RemoveNetworkDrive drive, True 'ネットワークドライブを解除します
Set objNtWork = Nothing
Case False
objNtWork.RemoveNetworkDrive drive, True 'ネットワークドライブを解除します
Set objNtWork = Nothing
m = MsgBox(w_filename & "のファイルがありません", vbOKOnly + vbExclamation, "ファイルオープンエラー")
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True: Exit Sub
End Select
'成形されたCSVﾃﾞｰﾀの格納(題目＆fieldindex以外の文字列＆数値data)
Application.StatusBar = filename(i) & "レコードデータ変換中です．．．．"
table = table_sw(m, table_w, lngREC(i) - 1, lngfil(i), w_filename)
If m = vbOK Then Exit Sub
'各作業用tableへ引渡し
Select Case i
Case 1
tsw1 = table
tw1 = table_w
Case 2
tsw2 = table
tw2 = table_w
End Select
ReDim table(1) As Integer: ReDim table_w(1) As Integer '読込メモリ解放
Next i
' Debug.Print table(1, 4)
'-----------------------------------------------------------------------------------------------------
'データ処理
Application.StatusBar = "ＣＳＶ加工結果、更新中です．．．．"
For y = 1 To ka_c '件数
i = 0: c = 0
For i = 1 To lngREC(1) - 1
If tsw1(i, 1) = "外来" And tsw1(i, 2) = ka_n(y) And _
Right(tsw1(i, 4), 3) <> " 合計" Then
' If tsw1(i, 1) = "外来" And tsw1(i, 2) = ka_n(y) Then
c = c + 1
End If
Next i
Workbooks(basefilename).Sheets("結果").Cells(3, 2 + y).Value = c
Next y
For y = 1 To ka_c '実日数
Workbooks(basefilename).Sheets("結果").Cells(4, 2 + y).Value = _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 6)
Next y
For y = 1 To ka_c + 1 '合計
Workbooks(basefilename).Sheets("結果").Cells(5, 2 + y).Value = _
"=SUM(R[2]C:R[13]C)"
Next y
For y = 1 To ka_c '初診
Workbooks(basefilename).Sheets("結果").Cells(7, 2 + y).Value = _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 10) * 10
Next y
For y = 1 To ka_c '再診他
Workbooks(basefilename).Sheets("結果").Cells(8, 2 + y).Value = _
(table_fg(lngREC(1) - 1, ka_n, y, tsw1, 11) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 12) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 13) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 14) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 15) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 16)) * 10
Next y
For y = 1 To ka_c '指導
Workbooks(basefilename).Sheets("結果").Cells(9, 2 + y).Value = _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 17) * 10
Next y
For y = 1 To ka_c '在宅
Workbooks(basefilename).Sheets("結果").Cells(10, 2 + y).Value = _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 18) * 10
Next y
For y = 1 To ka_c '投薬
Workbooks(basefilename).Sheets("結果").Cells(11, 2 + y).Value = _
(table_fg(lngREC(1) - 1, ka_n, y, tsw1, 19) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 20) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 21) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 22) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 23) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 24) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 25) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 26) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 27) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 28)) * 10
Next y
For y = 1 To ka_c '注射
Workbooks(basefilename).Sheets("結果").Cells(12, 2 + y).Value = _
(table_fg(lngREC(1) - 1, ka_n, y, tsw1, 29) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 30) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 31) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 32)) * 10
Next y
For y = 1 To ka_c '処置
Workbooks(basefilename).Sheets("結果").Cells(13, 2 + y).Value = _
(table_fg(lngREC(1) - 1, ka_n, y, tsw1, 33) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 34)) * 10
Next y
For y = 1 To ka_c '手術
Workbooks(basefilename).Sheets("結果").Cells(14, 2 + y).Value = _
(table_fg(lngREC(1) - 1, ka_n, y, tsw1, 35) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 36)) * 10
Next y
For y = 1 To ka_c '検査
Workbooks(basefilename).Sheets("結果").Cells(15, 2 + y).Value = _
(table_fg(lngREC(1) - 1, ka_n, y, tsw1, 37) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 38)) * 10
Next y
For y = 1 To ka_c '画像
Workbooks(basefilename).Sheets("結果").Cells(16, 2 + y).Value = _
(table_fg(lngREC(1) - 1, ka_n, y, tsw1, 39) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 40)) * 10
Next y
For y = 1 To 16 '(総合計[SUM式結果])
' Workbooks(basefilename).Sheets("結果").Cells(2 + y, 10).Value = _
WorksheetFunction.Sum(Range( _
Workbooks(basefilename).Sheets("結果").Cells(2 + y, 3), _
Workbooks(basefilename).Sheets("結果").Cells(2 + y, 9) _
))
Workbooks(basefilename).Sheets("結果").Cells(2 + y, 10).Value = _
"=SUM(RC[-7]:RC[-1])"
Next y
For y = 1 To ka_c '合計一致判断
If Not Workbooks(basefilename).Sheets("結果").Cells(5, 2 + y).Value = _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 9) * 10 Then
With Workbooks(basefilename).Sheets("結果").Cells(5, 2 + y).Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
Workbooks(basefilename).Sheets("結果").Cells(20, 2 + y).Value = _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 9) * 10
Workbooks(basefilename).Sheets("結果").Cells(21, 2 + y).Value = _
"=R[-16]C-R[-1]C"
End If
Next y
End Sub
'------------------------------------------------------------------------------------------------------------------
'品目別用演算関数（総レコード数,品番,table,フィールドナンバー）
'-----------------------------------------------------------------------------------------------------
Function table_hfg(count, code, table, fieldnumber As Long) As Double
Dim i As Long '作業領域
For i = 1 To count
If table(i, 1) = "外来" And table(i, 3) = code Then
table_hfg = table_hfg + (table(i, fieldnumber) * table(i, 5))
End If
Next i
End Function
'-----------------------------------------------------------------------------------------------------
'フィールド検索関数(table_w,総フィールド数,項目名)
'-----------------------------------------------------------------------------------------------------
Function field_sw(table_w, field, f_name) As Long
Dim c As Long '作業領域
For c = 1 To field
If table_w(1, c) = f_name Then
field_sw = c
Exit Function
End If
Next c
End Function
'-----------------------------------------------------------------------------------------------------
'フィールド合計演算関数（総レコード数,科コード（配列）,科コード配列No.table,フィールドナンバー）
'-----------------------------------------------------------------------------------------------------
Function table_fg(count, ka_n, y, table, fieldnumber As Long) As Double '
Dim i As Long '作業領域
For i = 1 To count
If table(i, 1) = "外来" And table(i, 2) = ka_n(y) And _
Right(table(i, 4), 3) <> " 合計" Then
' If table(i, 1) = 1 And table(i, 2) = ka(y) Then
table_fg = table_fg + table(i, fieldnumber)
End If
Next i
End Function
'-----------------------------------------------------------------------------------------------------
'CSV形式テキストファイル(不定カラム)読み込み関数（対象ファイルフル,レコード数(結果値),フィールド(結果値)）
'-----------------------------------------------------------------------------------------------------
Function READ_TextFile(w_filename, lngREC As Double, lngfil As Double) As Variant
Dim intFF As Integer ' FreeFile値
Dim strFileName As String ' OPENするﾌｧｲﾙ名(ﾌﾙﾊﾟｽ)
Dim X() As Variant ' 読み込んだﾚｺｰﾄﾞ内容
Dim IX1 As Double ' CSV項目ｶﾗﾑINDEX
Dim GYO As Double ' 収容するｾﾙの行
Dim strREC As String ' ﾚｺｰﾄﾞ領域
Dim POS1 As Double ' ﾚｺｰﾄﾞ文字位置INDEX
Dim POS2 As Double ' ﾚｺｰﾄﾞ文字位置INDEX
Dim REC() As String 'データ引渡し作業領域
Dim i As Double '作業カウント
Dim c As Double '作業カウント
Dim y As Variant '各変換作業領域
Dim z As Variant '各変換作業領域
Application.StatusBar = strFileName & "レコード数確認中です．．．．"
Open strFileName For Input As #intFF ' 指定ﾌｧｲﾙをOPEN(入力ﾓｰﾄﾞ)
GYO = 0: i = 0
Do Until EOF(intFF) ' ﾌｧｲﾙのEOF(End of File)まで繰り返す
i = i + 1
' Application.StatusBar = "レコード数確認中です．．．．(" & i & "レコード目)"
Line Input #intFF, strREC 'CSVデータをライン毎にstrRECへ取り込む
Loop
Close #intFF ' 指定ﾌｧｲﾙをCLOSE
End Function
'-----------------------------------------------------------------------------------------------------
'読み込んだcsvTextデータの数値文字に変換関数
'(エラー戻り値,table_w,総レコード数,総フィールド数,対象ファイルフル)
'-----------------------------------------------------------------------------------------------------
Function table_sw(m, table_w, count, field, w_filename) As Variant
Dim i As Long '作業領域
Dim c As Long '作業領域
Dim REC() As Variant 'データ引渡し作業領域
Dim err1 As Variant 'エラー値格納
ReDim REC(count, field) As Variant
m = vbNo
For i = 1 To count 'CSV無効データの強制有効化処理
For c = 1 To field
If IsError(table_w(1 + i, c)) Then
err1 = Cells(1 + i, c)
Select Case err1
Case CVErr(xlErrDiv0)
REC(i, c) = 0
Case CVErr(xlErrNA)
REC(i, c) = 0
Case CVErr(xlErrName)
REC(i, c) = 0
Case CVErr(xlErrNull)
REC(i, c) = 0
Case CVErr(xlErrNum)
REC(i, c) = 0
Case CVErr(xlErrRef)
REC(i, c) = 0
Case CVErr(xlErrValue)
REC(i, c) = 0
Case Else
m = MsgBox(w_filename & "ファイルにありえないケースのエラー値があります", _
vbOKOnly + vbExclamation, "値エラー")
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True: Exit Function
End Select
Else
If table_w(1 + i, c) = "" Or table_w(1 + i, c) = "#VALUE!" Then
REC(i, c) = 0
Else
If Val(table_w(1 + i, c)) <> 0 Then
REC(i, c) = Val(table_w(1 + i, c))
Else
If table_w(1 + i, c) = "0" Then
REC(i, c) = 0
Else
REC(i, c) = table_w(1 + i, c)
End If
End If
End If
End If
Next c
Next i
table_sw = REC
End Function
'-----------------------------------------------------------------------------------------------------
'空きDriveletter判断関数(ドライブ"A"&"B"は除外)
'-----------------------------------------------------------------------------------------------------
Function drive_s() As String
Dim file_system As Object 'CreateObject("Scripting.FileSystemObject")格納
Dim drive_collection As Object '利用できるDrivesコレクション格納
Dim member As Object '存在Driveletter名検索ナンバー格納
Dim drive_letter As Variant '検索&未使用Driveletter名格納
Dim drive_letter_w(26) As Variant '存在Driveletter名格納
Dim i As Integer '作業領域
Dim c As Integer '作業領域
Dim y As Variant '作業領域
Dim dr_n(26) As String '存在しないDriveletter名格納
'ファイルシステムへの参照を作成する
Set file_system = CreateObject("Scripting.FileSystemObject")
Set drive_collection = file_system.Drives '利用できるDrivesコレクションを取得する
For Each member In drive_collection 'Drivesコレクションの各メンバに繰り返し処理する
i = i + 1
drive_letter_w(i) = member.DriveLetter 'ドライブ文字を取得する
Next
Set file_system = Nothing
Set drive_collection = Nothing
c = 1: y = 1
For i = 1 To 26
If drive_letter(i) <> drive_letter_w(c) Then
dr_n(y) = drive_letter(i)
y = y + 1
Else
If drive_letter_w(c) = "Z" Then
Exit For
Else
If drive_letter(i + 1) <> drive_letter_w(c + 1) Then
c = c + 1
Else
If drive_letter(i + 1) <> drive_letter_w(c) Then
c = c + 1
End If
End If
End If
End If
' Debug.Print "検査:" & drive_letter(i) & " 論理:" & drive_letter_w(c):
Next i
c = 1
For Each y In dr_n
If y = "A" Or y = "B" Then c = c + 1
Next
drive_s = dr_n(c)
End Function
'-----------------------------------------------------------------------------------------------------
'pc_user名取得関数
'-----------------------------------------------------------------------------------------------------
Function pc_user_name() As String
Dim strBuffer As String '作業領域
Dim lngLngs As Long '作業領域
Dim lngRet As Long '作業領域
End Function
'------------------------------------------------------------------------------------------------------------------
'ネットワークドライブ割当可否判断関数1(セットオブジェクト名,ドライブ名,パス)
'------------------------------------------------------------------------------------------------------------------
Function drive_m1(objNtWork, drive, link_dr) As Boolean
On Error GoTo ErrorExit
End Function
'-----------------------------------------------------------------------------------------------------
'ネットワークドライブ割当可否判断関数2(セットオブジェクト名,ドライブ名,パス)
'-----------------------------------------------------------------------------------------------------
Function drive_m2(objNtWork, drive, link_dr) As Boolean
End Function
'-----------------------------------------------------------------------------------------------------
'ファイルオープン可否判断関数1(対象ファイルフル,ファイル名)
'-----------------------------------------------------------------------------------------------------
Function f_Open(strFileName As Variant, filename As Variant) As String
'引数 strFileName のファイルが実際にあるかチェックするし、
'有れば当該ファイルを変更可能状態で開きTrueを返す、無ければFalseを返す
End Function
'-----------------------------------------------------------------------------------------------------
'月MAX日数可否判断関数
'-----------------------------------------------------------------------------------------------------
Function nissuu()
Dim basefilename As String 'マクロ実行ファイル名
Dim j_year As Integer '和暦数格納
Dim w_year As Integer '西暦数格納
Dim month As Integer '月格納
Dim month2 As Integer '閏年判断で成形された日数格納
Dim day_max As Variant '対象年の月MAX日数格納（配列）
'イベント監視停止
Application.EnableEvents = False
'マクロ実行ファイル名取得
basefilename = ActiveWorkbook.Name
'和暦＆月数入力チェック及び、閏年２月MAX日数判断＆結果書き込み
If Not IsNumeric(Workbooks(basefilename).Sheets("読込設定").Cells(2, 6)) Or _
Not IsNumeric(Workbooks(basefilename).Sheets("読込設定").Cells(3, 6)) Then
Workbooks(basefilename).Sheets("読込設定").Cells(2, 8).Value = ""
Else
j_year = Workbooks(basefilename).Sheets("読込設定").Cells(2, 6)
month = Workbooks(basefilename).Sheets("読込設定").Cells(3, 6)
If j_year = Empty Or month < 1 Or month > 12 Or month = Empty Then
Workbooks(basefilename).Sheets("読込設定").Cells(2, 8).Value = ""
Else
w_year = j_year - 20 + 2008
If (w_year Mod 4) = 0 And (w_year Mod 100) <> 0 Or (w_year Mod 400) = 0 Then
month2 = 29
Else
month2 = 28
End If
day_max = Array(31, month2, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
Workbooks(basefilename).Sheets("読込設定").Cells(2, 8).Value = day_max(month)
End If
End If
'イベント監視再開
Application.EnableEvents = True
End Function
