DRAGONのブログ一覧

気温あがんねー(;^_^A アセアセ･･･



職場の雪もなかなか溶けねー(苦笑)



寒くて１０分外ににいられないし・・・



ますますラリーカーのようになっていくオイラのレガ(笑)



まこの寒さは今週いっぱいまで



続くみたいだから仕方ないけど、



寒すぎるよー{{ (>_<) }} サムイーッ！！



そんな事は良いとして、昨日は以前ＰＳＰが壊れるまで使っていた、



メモステDuoの４ギガが行方不明になってて見つからない(; ;)ﾎﾛﾎﾛ



この捜し物をしていると、今はまだ使うつもりのないカスタムファームのツールキットが出てきたり(笑)。



中学時代から持っていたウノが出てきたり。。。



記憶が薄れかけてた○○○が書いた



大量のレターと、裏にメッセが書かれた大量のテレカが(笑



)出現したり(;^_^A アセアセ･･･



関係ない物がどんどん出てくる(笑)。



ＰＳＰが壊れた後に何かに使った記憶があるんだけど、



何に使ったか覚えてねー(;^_^A ｱｾｱｾ･･･



諦めて、ＰＳ＠ＨＯＭＥでフレと交流して・・・



ＰＳ３をＰＳＰで操作＆画面が見られる



リモートプレイが出来ることを思い出し、



試しにやってみたり(笑)



ある意味充実したアフターと言うかnight☆でした(笑)。



リモートプレイの使用感は、まだ試したいことがあるので、後日書きますね。

２年前に子供に壊されたＰＳＰ－１０００・・・



せっかくＰＳ３を買ったんで



ＰＳＰ初期型の中古なら、



そんなに高くないので買おうとは



思っていたのだけど・・・



昨日出張で買い物しに行ったついで（そのまま直帰だから）に



買い物先の隣にあるブックオフとハードオフに寄って



１週間前にブックオフにあった、ＰＳＰ－１０００黒を



職場の買い物終わった後に買おうと思って



ブックオフに寄ってみたら・・・



売れて無くなってました・・・＿|￣|○・・・はうぅ・・・



まぁね・・・



一万以下になってたし、



今でも初期型は一部の人には、人気の型式なので仕方ないか。。。



って買う気満々で行ったのでかなりショックでした。




半分諦めモードでハードオフに探しに行ったら、



封印シールがないからジャンク扱いになっていたけど、



ＰＳＰ－１０００ブルーがブックオフにあった黒と



同じ価格で売ってたんで速効店員捕まえて、



ショーケースから出して貰い封印シール意外に不具合がないことが確認できたし、



この封印シールが無いと当然の事ながら、



メーカー修理は不可だけど、しばらくしたら、



どうせまたカスタムファーム入れちゃうので、



どのみちメーカー修理出来なくしちゃうから、



封印シールがあっても同じなので、



ＰＳＰの青を買って来ちゃいました。



でも一つ気になることが・・・



封印シールがあって通常中古として


ブックオフで売られていた黒のＰＳＰの価格と



ジャンクでオイラが買ったＰＳＰ青の価格が



同じなのは何故だ(笑)



店員に突っ込んだとけど、



解りませんって・・・(ﾟﾟ;)＼(--;)ｵｲｵｲ ﾅﾆｲｯﾃﾝﾀﾞﾖ



店によって買い取り価格が違うのは解るけど。。。



査定基準は同じだよな。。。。



こんな商売の仕方で良いのかちょっと疑問・・・

今朝撮れなかったので、この写真は去年の物ですが・・・



一面銀世界の中通勤してきました(笑)



積雪は・・・深いところの目視で１０センチ前後(笑)



ま、職場までの道のりで、今日は除雪作業を早くからしてたみたいで、６０％位は除雪されてましたけど、、、



シャーベット状で逆に恐かった(苦笑)



残りの４０％は・・・轍が何故か２本(笑)



時折３本になるけど殆ど２本でして(苦笑)



いかに交通量が少ないか解ってしまいますが(笑)



こんな道なんで、轍がオイラの車に合わなくて



常にハンドル切ってないとまっすぐ走らね(笑)



っていう状況で軽い運動しながら職場に着きました(笑)。



家に帰るころには、除雪されて溶けちゃって余裕で帰れるんだとげね(笑)



でも今日は八王子でお買い物しなきゃなので、



夕方出張で買い物してそのまま直帰かな。。。



見かけたら声かけて貰っても構わないですが、



本人人見知り激しいのでキョドルかも知んないけど許してねー(笑)

皆さんお久しぶりです(^^;ゞ

医事システム&ＰＣ入替えとマクロの作り直しで
ここ数週間忙しかったのと、体調不良で上からも下からも(^^;ゞで
３日程ダウンしたりしてまして(^^;ゞ更新できずにいました。


ご心配お掛けしたが、相変わらず忙しいですが、取りあえずブログ復活しますんで、ご安心を・・・



でですねー・・・



更新できない間に、レガが今度は金属系の悲鳴をあげて、、、



調べて貰った結果、プーリーのベアリング・・・・



しかもパワステポンプ近くのプーリー(笑)



ってなことで、Ｄラー側から値引掲示してくれたんで、



何も言いませんでしたが、もし満額だったら



( ﾟДﾟ)ｺﾞﾙｧ!!してたかも(笑)



あとは・・・・



ＰＳ＠ＨＯＭＥでフレが増えたことかな・・・



ストレス発散で夜な夜なカフェでバカ騒ぎしてます(笑)






そうそう、初めてＢＤ（ブルーレイディスク）見たけど、



絵が綺麗だね・・・



もちろんＰＳ３がある部屋のテレビだから、



Ｄ１で見ているから、ＤＶＤとの違いは無いと思ったけど、



ソースの違いからなのか、違いが確認できました。



なんて言うんだろ・・・



ＢＤの方がよりクッキリハッキリしているように思う。



こんなの見ると、ますますテレビを代えたくなってきた



今日この頃・・・



誰かアナログでも良いからＤ４対応テレビくれー(笑)



ｴｯ?(?_?)ｴｯ?何故アナログで良いかって(笑)



だって・・・地デジ難民だもん(笑)



多分地デジは・・・



ケーブル会社に高い料金払ってみるんだろうな。。。うちの親父は・・・



フレッツ光の回線はすでにオイラが契約して使っているから、



フレッツ光テレビにしたらランニングは安いのに・・・



「月１万近く払う」てどっかで聞いてきたみたいで、、、



（１万近くって言うのはネット料金も含まれているわけだし・・・、
オイラはその基本料払っているし・・・数百円増えるだけなら別に・・・）



「月千円もかからないよ」って



いっても聞く耳持たない・・・



いつになっ＋たら家は地デジカになるのやら・・・(笑)



あとは・・・



一部だけど、こんなの今作っているマクロ・・・


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 'アプリケーションコマンドセット

'-----------------------------------------------------------------------------------------------------
'前処理

Application.StatusBar = "初期設定中です．．．．"
Application.ScreenUpdating = False
Application.EnableEvents = False

basefilename = ActiveWorkbook.Name 'マクロ実行ファイル名取得

'和暦＆月数取得
j_year = Workbooks(basefilename).Sheets("読込設定").Cells(2, 6)
month = Workbooks(basefilename).Sheets("読込設定").Cells(3, 6)

'和暦＆月数入力チェック及び、閏年２月MAX日数判断＆結果書き込み
If Not IsNumeric(j_year) Then j_year = "moji"
If Not IsNumeric(month) Then month = "moji"
If j_year = Empty Or j_year = "moji" Then
Select Case j_year
Case Empty
m = MsgBox( _
"処理年が 0 または未入力です。" & vbCr & vbCr & _
"H19年以降の数字を入力して下さい。", _
vbOKOnly + vbExclamation, "処理年値エラー")
Case "moji"
m = MsgBox( _
"処理年入力に数字以外の物の入力があります。" & vbCr & vbCr & _
"H19年以降の数字を入力して下さい。", _
vbOKOnly + vbExclamation, "処理年値エラー")
End Select
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True: Exit Sub
Else
If month < 1 Or month > 12 Or month = Empty Or j_year = "moji" Then
Select Case j_year
Case Empty
m = MsgBox( _
"処理月が 0 または未入力です。" & vbCr & vbCr & _
"1 から 12 の数字を入力して下さい。", _
vbOKOnly + vbExclamation, "処理月値エラー")
Case Is < 1, Is > 12
m = MsgBox( _
"処理月が 異常値です。" & vbCr & vbCr & _
"1 から 12 の数字を入力して下さい。", _
vbOKOnly + vbExclamation, "処理月値エラー")
Case "moji"
m = MsgBox( _
"処理月入力に数字以外の物の入力があります。" & vbCr & vbCr & _
"1 から 12 の数字を入力して下さい。", _
vbOKOnly + vbExclamation, "処理月値エラー")
End Select
Else
ReDim j_year(1) As Integer: ReDim month(1) As Integer
j_year = Workbooks(basefilename).Sheets("読込設定").Cells(2, 6)
month = Workbooks(basefilename).Sheets("読込設定").Cells(3, 6)
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
month3 = "0" & month

'パス格納&パス成形
dr = Workbooks(basefilename).Sheets("読込設定").Cells(2, 2)
link_dr = Left(dr, 21)

'ファイル名格納
filename(1) = Workbooks(basefilename).Sheets("読込設定").Cells(3, 2) & w_year & Right(month3, 2) & "01_" & w_year & Right(month3, 2) & day_max(month) & ".csv"
filename(2) = Workbooks(basefilename).Sheets("読込設定").Cells(4, 2) & w_year & Right(month3, 2) & "01_" & w_year & Right(month3, 2) & day_max(month) & ".csv"

'Debug.Print filename(1)
'Debug.Print filename(2)

'科コード名読み取り
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の排除

'結果シート出力範囲クリア
Range(Workbooks(basefilename).Sheets("結果").Cells(3, 3), _
Workbooks(basefilename).Sheets("結果").Cells(18, 10)).Clear
Range(Workbooks(basefilename).Sheets("結果").Cells(20, 3), _
Workbooks(basefilename).Sheets("結果").Cells(21, 10)).ClearContents

'-----------------------------------------------------------------------------------------------------
'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(6, 2 + y).Value = _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 8) + _
(table_hfg(lngREC(2) - 1, 380, tsw2, field_sw(tw2, lngfil(1), ka_n(y)))) * -1 + _
(table_hfg(lngREC(2) - 1, 381, tsw2, field_sw(tw2, lngfil(1), ka_n(y)))) * -1 + _
(table_hfg(lngREC(2) - 1, 384, tsw2, field_sw(tw2, lngfil(1), ka_n(y)))) * -1 + _
(table_hfg(lngREC(2) - 1, 385, tsw2, field_sw(tw2, lngfil(1), ka_n(y)))) * -1
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 ka_c '精神療法他（品目リハビリ分差引計算有り）
Workbooks(basefilename).Sheets("結果").Cells(17, 2 + y).Value = _
(table_fg(lngREC(1) - 1, ka_n, y, tsw1, 41) + _
table_fg(lngREC(1) - 1, ka_n, y, tsw1, 42)) * 10 - _
(table_hfg(lngREC(2) - 1, 8030, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8035, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8195, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8196, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8040, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8123, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8590, tsw2, field_sw(tw2, lngfil(1), ka_n(y)))) * 10
Next y

For y = 1 To ka_c 'リハビリ分（品目）
Workbooks(basefilename).Sheets("結果").Cells(18, 2 + y).Value = _
(table_hfg(lngREC(2) - 1, 8030, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8035, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8195, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8196, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8040, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8123, tsw2, field_sw(tw2, lngfil(1), ka_n(y))) + _
table_hfg(lngREC(2) - 1, 8590, tsw2, field_sw(tw2, lngfil(1), ka_n(y)))) * 10
'Debug.Print ka_n(y) & ":" & field_sw(tw1, lngfil(1), ka_n(y))
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


' Workbooks(basefilename).Sheets("結果").Select
' Range(Cells(3, 10), Cells(18, 10)).Value = "=SUM(RC[-1]:RC[-7])"
' Range(Cells(3, 10), Cells(18, 10)).Value = Range(Cells(3, 10), Cells(18, 10)).Value

'------------------------------------------------------------------------------------------------------------------
'後処理
Workbooks(basefilename).Sheets("結果").Select
Application.StatusBar = "処理完了です．．．．"
Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "ファイル読み込みが完了しました。" & vbCr & _
vbCr & _
"パス名= " & dr & vbCr & vbCr & _
" ファイル名= " & filename(1) & vbCr & _
" 更新日時= " & file_date(1) & vbCr & _
"ﾚｺｰﾄﾞ件数= " & lngREC(1) & "件 " & "ﾌｨｰﾙﾄﾞ件数= " & lngfil(1) & "件" & vbCr & _
vbCr & _
" ファイル名= " & filename(2) & vbCr & _
" 更新日時= " & file_date(2) & vbCr & _
"ﾚｺｰﾄﾞ件数= " & lngREC(2) & "件 " & "ﾌｨｰﾙﾄﾞ件数= " & lngfil(2) & "件", _
vbInformation, "テキストファイル読み込み処理"

' Workbooks(basefilename).Sheets("1").Cell = tw2

Erase tw1, tw2, tsw1, tsw2, table, table_w
Application.StatusBar = False

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 '各変換作業領域

strFileName = w_filename 'csvフルパスファイル名引渡し

'-----------------------------------------------------------------------------------------------------
'前処理（引渡し配列変数設定のためのレコード数カウント）
intFF = FreeFile ' FreeFile値の取得(以降この値で入出力する)

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

ReDim REC(i, 256) As String

'-----------------------------------------------------------------------------------------------------
'csvデータ読込＆加工

Application.StatusBar = strFileName & "読み込み中です．．．．"
Open strFileName For Input As #intFF
Do Until EOF(intFF)
'0 ﾚｺｰﾄﾞ件数ｶｳﾝﾀの加算
lngREC = lngREC + 1
' Application.StatusBar = "読み込み中です．．．．(" & lngREC & "レコード目" & ")"
Line Input #intFF, strREC 'CSVデータをライン毎にstrRECへ取り込む

'-----------------------------------------------------------------------------------------------------
' LineInputより自分で半角ｶﾝﾏを探しCSV→項目分割させる
POS1 = 1
IX1 = 1
ReDim X(IX1) ' 配列を初期化
Do While POS1 <= Len(strREC)
' POS2 = InStr(POS1, strREC, ",", vbTextCompare)
POS2 = InStr(POS1, strREC, ",", vbBinaryCompare)
If POS2 < POS1 Then
POS2 = Len(strREC) + 1
End If
ReDim Preserve X(IX1) ' 配列数を再設定
X(IX1) = Trim$(Mid$(strREC, POS1, POS2 - POS1))

'Debug.Print X(IX1)

' ｼﾝｸﾞﾙｺｰﾃｰｼｮﾝ､ﾀﾞﾌﾞﾙｺｰﾃｰｼｮﾝで囲まれている場合は
' 両端文字を取り除く
If (((Left$(X(IX1), 1) = """") And (Right$(X(IX1), 1) = """")) Or _
((Left$(X(IX1), 1) = "'") And (Right$(X(IX1), 1) = "'"))) Then
X(IX1) = Trim$(Mid$(X(IX1), 2, Len(X(IX1)) - 2))
End If
POS1 = POS2 + 1
IX1 = IX1 + 1
Loop

'-----------------------------------------------------------------------------------------------------
' ﾚｺｰﾄﾞ内容を引き渡し用変数に変換＆蓄積

If lngfil < IX1 Then lngfil = IX1 - 1

GYO = GYO + 1
If IX1 >= 1 Then
i = 0
For Each y In X
i = i + 1
REC(GYO, i) = y ' 配列渡し
Next
End If
Loop
Close #intFF ' 指定ﾌｧｲﾙをCLOSE

'-----------------------------------------------------------------------------------------------------
'読み込んだデータの配列領域を成形し直し

y = REC

ReDim REC(GYO, lngfil) As String

For c = 1 To GYO
For i = 1 To lngfil
REC(c, i) = y(c, i) ' 配列渡し
Next
Next c

Application.StatusBar = False
'-----------------------------------------------------------------------------------------------------
'csvデータの引渡し

READ_TextFile = REC

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コレクションを取得する

drive_letter = Array("A", "B", "C", "D", "E", "F", "G", _
"H", "I", "J", "K", "L", "M", "N", _
"O", "P", "Q", "R", "S", "T", "U", _
"V", "W", "X", "Y", "Z" _
)

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 '作業領域

' Bufferを確保
strBuffer = String(256, Chr(0))
lngLngs = Len(strBuffer)

' ログインユーザー名取得
lngRet = GetUserName(strBuffer, lngLngs)
' Null文字の手前までを有効として表示
pc_user_name = Left$(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)

End Function
'------------------------------------------------------------------------------------------------------------------
'ネットワークドライブ割当可否判断関数1(セットオブジェクト名,ドライブ名,パス)
'------------------------------------------------------------------------------------------------------------------
Function drive_m1(objNtWork, drive, link_dr) As Boolean
On Error GoTo ErrorExit

objNtWork.MapNetworkDrive drive, link_dr, , "******", """"

drive_m1 = True
Exit Function

ErrorExit:
drive_m1 = False

End Function
'-----------------------------------------------------------------------------------------------------
'ネットワークドライブ割当可否判断関数2(セットオブジェクト名,ドライブ名,パス)
'-----------------------------------------------------------------------------------------------------
Function drive_m2(objNtWork, drive, link_dr) As Boolean

On Error GoTo ErrorExit

objNtWork.MapNetworkDrive drive, link_dr, , pc_user_name, "******"

drive_m2 = True
Exit Function

ErrorExit:
drive_m2 = False

End Function
'-----------------------------------------------------------------------------------------------------
'ファイルオープン可否判断関数1(対象ファイルフル,ファイル名)
'-----------------------------------------------------------------------------------------------------
Function f_Open(strFileName As Variant, filename As Variant) As String
'引数 strFileName のファイルが実際にあるかチェックするし、
'有れば当該ファイルを変更可能状態で開きTrueを返す、無ければFalseを返す

On Error GoTo ErrorExit

Workbooks.Open filename:=strFileName, ReadOnly:=True
Workbooks(filename).Close SaveChanges:=False

f_Open = True
Exit Function

ErrorExit:
f_Open = 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





こんなの(;^_^A ｱｾｱｾ･･･



似たような物を数週間にわたって、毎日何個も眺めているんで、



いくら自分が作ったものとはいえ、



BRAIN-BAN!!



しそうです(;^_^A ｱｾｱｾ･･･

ＰＳ３三昧(笑)


９日の夜にＰｌａｙＳｔａｔｉｏｎ＠ＨＯＭＥで、



知り合ったというか、、、



突然フレンド登録をしたいってきた、１０歳の子に、



出会ってそのまま、翌日の明け方５時まで相手させられたり、、、



昨日は昨日で、昼過ぎに、コメント内容から、



多分女の子で日本語が解る外人さんか子供（少し日本語おかしかった）に逆ナンされて遊び相手になったり・・・



普通じゃ有りえない事になってます(苦笑)



私自身はイベントで条件をみたすと貰える、



リワードアイテム（今だとロコロコ関係かな。。。）が集まればいいし、



別にあの世界で今更フレンドを増やすつもりはないんだが(笑)



どうもｵｺﾁｬﾏと外人さんに声かれられる確率が高ーい(;^_^A ｱｾｱｾ･･･



ま、これはこれで人脈として何かの役に立つかも(謎)



なので、別に拒みはしないけどね。。。



でも、人に話しかけるときに、



いきなり「フレンド登録して下さい」とか



女のアバターで突然目の前や横に来て「大好き」って言ってくる人は



かなり対応に困るのだけど、それは私が年取ったせいだけじゃないよね？？？






ま、そんな事は良いとして。。。



１０日は１０歳の子のおかげで、昼間で寝てた私は、



ＰＳ２をつなげるために、



ケーブルやら電源タップやＵＳＢハブ等を買いに、



厚木のダイソ－とヤマダ電機へ



下の息子を連れて行ってきました。



ダイソーで電源タップとＵＳＢハブを買うつもりが、



ＵＳＢハブ無い(; ;)ﾎﾛﾎﾛ



以前はあったのだけど。。。



仕方ないので、１０５円の電源タップのみ買って、ヤマダ電機へ



まずは目的のＰＳ用のＤ端子ケーブルと



安めのＵＳＢハブ・・・って思ったら、



特価千円以下のＵＳＢハブは売り切れ(;^_^A ｱｾｱｾ･･･



仕方ないので普通の安めのものを探して、



ちょっと予算オーバー(笑)したけどゲットしてきました。




それとＤＳｉのキャラカバーがあったので、



それをついでにゲットして帰ってきました。



この日は弟ﾌｧﾐﾘｰも来ていたので、



上の娘はケーキを一緒に買いに行ったみたいですが、



何となくバタ付いた１日でした。






でですね。。。



昨日もＰＳ＠ＨＯＭＥで付合わされ・・・



起きたのが昼過ぎ(;^_^A ｱｾｱｾ･･･



その間何度か下の息子に起こされる（ゲームがしたいから）けど



流石に起きれませんでした。。。。



で起きたあと、、、



ＰＳ３で息子とゲームして・・・



ＰＳ２繋いで・・・



今度はＰＳ２で息子とゲームして・・・



私が寝る前にリワードアイテム取得するために、



チラッとＰＳ３して・・



ＰＳ三昧な日でした(笑)