| 内容 | Option Explicit
On Error Resume Next
'CSV-Excel変換スクリプト(医療機関NW用)
'ドラック＆ドロップされたCSVファイルを結合、Excelに変換する
'引数の数を確認－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Dim args, arg, strArg, argNum
Set args = WScript.Arguments
'引数の数を確認
argNum = args.Count
'引数が１つもなければ
If argNum = 0 Then
'スクリプトを終了
Wscript.Echo "CSV-Excel変換スクリプト" & vbCrLf & vbCrLf & "このツールは、" & vbCrLf & _
"CSVファイルをExcelファイルに変換します。" & vbCrLf & _
"このツールの上に対象のCSVファイルをドラック＆ドロップして下さい。" & strSkip
WScript.Quit
End If
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'CScriptに切り替え－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'引数を取得
Dim args0, arg0, strArg0, argNum0
Set args0 = Wscript.Arguments
Dim strMyName ' コマンド名
strMyName = UCase(Replace(WScript.FullName, WScript.Path & "\", ""))
If strMyName = "WSCRIPT.EXE" Then
For arg0 = 0 to args0.Count - 1
strArg0=strArg0 & " """ & args0(arg0) & """"
Next
strArg0= "cscript.exe " & """" & wscript.scriptfullname & """" & strArg0
'WScript.Echo strArg0
CreateObject("WScript.Shell").run(strArg0)
WScript.Quit
End If
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'メイン処理－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'変数定義
Dim MaxRowNum
Dim MaxColNum
Dim SkipRow
Dim strSkip
Dim TitleRow
Dim strTitileRow
Dim objFSO 'FileSystemObject
Dim objRE '文字検索用
Dim objExcel
Dim objSheet
Dim objWFile 'ファイル書き込み用
Dim objRFile 'ファイル読み込み用
Dim strToolFolder
Dim strDataFolder
Dim strDataFile
Dim strTitle
Dim strTitledata
Dim argTitles
Dim strSaveFile
Dim strTDivide
Dim strDivide2
Dim strObjNum
Dim strBaseName
Dim strExtName
'CSV読み込み条件を設定
SkipRow = 1 'スキップ行数
TitleRow = 1 'タイトル行数
strTDivide = "_"
strDivide2 = ""","""
'"I:\41_医療機関ネットワーク\医療機関NW登録用\DATA"
'csvファイル操作のためのファイルシステムオブジェクトの作成
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
'正規表現利用のためのオブジェクトの作成
Set objRE = CreateObject("VBScript.RegExp")
'スクリプトのパスを取得
strToolFolder = objFSO.getParentFolderName(WScript.ScriptFullName)
'引数を確認－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'最初の引数の値を変数に格納
strDataFolder = objFSO.getParentFolderName(args(0))
strDataFile = objFSO.getFileName(args(0))
strBaseName = objFSO.getBaseName(args(0))
strExtName = objFSO.GetExtensionName(args(0))
argTitles = Split(strDataFile , strTDivide)
'拡張子が「csv」でない場合
If (strExtName <> "csv") and (strExtName <> "CSV") Then
'スクリプトを終了
Wscript.Echo "対象外のファイルが含まれています。" & vbCrLf & vbCrLf & _
"正しいファイルをドラック＆ドロップして下さい。", 48, "CSV-Excel変換ツール(医療機関NW用)"
WScript.Quit
End If
'条件表示用の内容を設定
If SkipRow <> 0 Then
strSkip = vbCrLf & vbCrLf & "＊注意＊" & vbCrLf & "CSV取り込みの設定は、以下の通りです。" & vbCrLf & _
"・行頭" & SkipRow & "行スキップ"
Else
strSkip = ""
End If
If TitleRow <> 0 Then
strSkip = strSkip & vbCrLf &"・タイトル行あり"
End If
'現在日時を取得
Dim strNow
Dim strCDate
Dim strCTime
strNow = Replace(Left(Now(),10), "/", "") & Replace(Replace(Right(Now(),8)," ","0"), ":", "")
'Wscript.Echo strNow
strCDate = Left(strNow,8)
strCTime = Right(strNow,6)
'接頭タイトルを取得
If UBound(argTitles) > 1 Then
strTitle = argTitles(0)
End If
'結果保存用フォルダ名
'strFolder = strDataFolder & "\" & strCDate & strTitle & "_変換結果"
strFolder = strDataFolder & "\" & strBaseName
'ファイルの内容を確認
'ファイルが複数ある場合
If argNum > 1 Then
Dim strResult
'接頭タイトルがなければ、
If strTitle = "" Then
'スクリプトを終了
Wscript.Echo "ファイル名が不正です。" & vbCrLf & vbCrLf & _
"結合するファイルは、同じ「*_」で始まる形としてください。" & vbCrLf & _
"ツールを終了します。", 48, "CSV-Excel変換ツール(医療機関NW用)"
WScript.Quit
End If
'対象引数のパターンを設定
objRE.Pattern = "^" & strTitle & ".*" & ".csv$"
'対象引数を表示
For Each arg In args
arg = objFSO.getFileName(arg)
If objRE.Test(arg) Then
strObjNum = strObjNum 1
strArg = strArg & arg & vbCrLf
End If
Next
'確認ダイアログを表示
strResult = Wscript.Echo (strTitle & " を処理します。" & vbCrLf & _
"処理対象は、以下の " & strObjNum & " 件です。" & vbCrLf & vbCrLf & _
strArg & vbCrLf & vbCrLf & "よろしいですか？" & strSkip & vbCrLf & vbCrLf & _
"処理にはしばらく時間がかかることがあります。" & vbCrLf & _
"処理が終了するとダイアログが表示されます。", 65, "CSV-Excel変換ツール(医療機関NW用)")
'キャンセルの場合は、スクリプトを終了
If strResult = 2 Then
WScript.Quit
End If
'ファイルが一つの場合
Else
'接頭タイトルがなければ、
If strTitle = "" Then
'対象引数のパターンを設定
objRE.Pattern = "^" & strTitle & ".*" & ".csv$"
Else
'対象引数のパターンを設定
objRE.Pattern = "^.*" & ".csv$"
End If
arg = objFSO.getFileName(args(0))
'CSVファイルの場合
If objRE.Test(arg) Then
'確認ダイアログを表示
'strResult = MsgBox ("処理対象は、以下の " & argNum & " 件です。" & vbCrLf & vbCrLf & _
' strDataFile & vbCrLf & vbCrLf & "よろしいですか？" & vbCrLf & _
' strSkip & vbCrLf & _
' "処理にはしばらく時間がかかることがあります。" & vbCrLf & _
' "処理が終了するとダイアログが表示されます。", 36, "CSV-Excel変換ツール(医療機関NW用)")
'キャンセルの場合は、次の確認ダイアログを表示
If strResult = 7 Then
WScript.Quit
End If
'CSVファイルでない場合は、スクリプトを終了
Else
Wscript.Echo "対象外のファイルです。" & vbCrLf & vbCrLf & "正しいファイルをドラック＆ドロップして下さい。", 48, "CSV-Excel変換ツール(医療機関NW用)"
WScript.Quit
End If
End If
'ファイル処理開始－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Dim count
Dim tcount
Dim strData
Dim strdata0
Dim strdata1
Dim FileName
Dim strFolder
Dim arrDataList
Dim arrFieldList
Dim strFieldList
Dim i
Dim j
Dim rrr
'Excel起動－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'Excel操作のためのオブジェクトの作成
Set objExcel = CreateObject("Excel.Application")
'起動状況確認
If objExcel Is Nothing Then
'Excel起動失敗
Wscript.Echo "Excel起動失敗"
Else
'Excel起動成功
'--Excel表示（falseにすると非表示にできる）
'objExcel.Application.Visible = true
objExcel.Application.Visible = false
'--Excelの警告を非表示にする
objExcel.Application.DisplayAlerts = false
'--3秒待つ
WScript.Sleep(3000)
'--ブック追加
objExcel.Application.Workbooks.Add()
'不要なシートを削除
If objExcel.Worksheets.Count <> 1 Then
For i = objExcel.Worksheets.Count to 2 step -1
objExcel.Worksheets(i).Delete
Next
End If
'--シート選択
Set objSheet = objExcel.Worksheets(1)
'保存先フォルダ有無確認
'フォルダがあれば
If objFSO.FolderExists(strFolder) = True Then
'strMessage = "フォルダ " & strFolder & " は既に存在しています。"
'フォルダがなければ
Else
'ファルダ作成
objFSO.CreateFolder(strFolder)
'フォルダの作成状況確認
'フォルダが作成に成功すれば
If Err.Number = 0 Then
'strMessage = "フォルダ " & strFolder & " を作成しました。"
'フォルダが作成に失敗すれば
Else
strMessage = "エラー: " & Err.Description
End If
End If
'csvファイルを開く－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'csvファイル毎に処理をする
For i = 1 to argNum
If objRE.Test(objFSO.getFileName(args(i-1))) Then
'csvファイルを読み込む
set objRFile = objFSO.OpenTextFile(args(i-1))
'読み込み状況確認
'読み込みに成功したら
If Err.Number = 0 Then
'strFieldList = objRFile.ReadLine
'arrFieldList = Split(strFieldList , ",")
'WScript.Echo Ubound(arrFiledList)
'スキップ行設定実施
If SkipRow <> 0 Then
For j = 1 to SkipRow
'1行読み飛ばし
strdata0 = objRFile.ReadLine
Next
End If
'2ファイル目以降タイトル行読み飛ばし
If TitleRow = 1 Then
'処理ファイル数確認
If count > 0 Then
'1行読み飛ばし
strdata0 = objRFile.ReadLine
End If
End If
'EOF(End Of File)に達するまで繰り返す
Do Until objRFile.AtEndOfStream = True
If strTitledata<>"" Then
strdata0=strTitledata
strTitledata=""
Else
'１行読み込み
strdata0 = ""
strdata0 = objRFile.ReadLine
'WScript.Echo strdata0
End If
'CSVファイルを開く
'objFSO.OpenTextFile(args(i-1))
'データの最後の文字を確認
'最後の文字が「"」であれば
IF Right(strdata0,1) = """" AND Right(strdata0,3) <> """,""" Then
'データを結合
strdata0 = strdata1 & strdata0
strdata1 = ""
strdata0 = Left(strdata0,Len(strdata0))
strdata0 = Right(strdata0,Len(strdata0))
'各データを配列に格納
arrDataList = Split(strdata0 , strDivide2)
'WScript.Echo Ubound(arrDataList)
If count = 0 Then
' カラム幅設定
'objSheet.Columns("C").ColumnWidth = 20
MaxColNum=Ubound(arrDataList)
For j = 0 to MaxColNum
' カラムの書式設定の表示形式を文字列にする
objSheet.Columns(j 1).NumberFormatLocal = "@"
Next
End If
count = count 1
'FileName = strFolder & "\" & Replace(arrDataList(2),"""","") & Replace(arrDataList(1),"""","") & ".txt"
'Set objWFile = objFSO.OpenTextFile(FileName, 2, True)
'If Err.Number = 0 Then
For j = 0 to Ubound(arrDataList)
'strData = "[" & Replace(arrFieldList(i),"""","") & "]" & Replace(arrDataList(i),"""","")
'テキストファイルに書き込む
'objWFile.WriteLine(strData)
'セルに値を設定
objSheet.Cells(count,j 1).value = Replace(arrDataList(j),"""","")
Next
'objWFile.Close
'Else
'WScript.Echo "ファイルオープンエラー: " & Err.Description
'End if
'データの終りでなければ
'データを一旦格納
Else
If strdata1 = "" Then
strdata1 = strdata0 & vbCrLf '１行目のデータ
Else
strdata1 = strdata1 & strdata0 & vbCrLf '２行目以降のデータ
End if
End If
Loop
'csvファイルの開放
objRFile.Close
Else
WScript.Echo "エラー: " & Err.Description
End If
'tcount = tcount count
'count = 0
End If
Next
'XlDirection 移動する方向を指定します。
'xlDown -4121 下へ
'xlToLeft -4159 左へ
'xlToRight -4161 右へ
'xlUp -4162 上へ
'objExcel.Application.Visible = true
MaxRowNum=objSheet.Cells(objSheet.Rows.Count, 1).End(-4162).Row
'MaxRow=objSheet.Cells(1, 1).End((-4121).Row
MaxColNum = objSheet.Cells(1, objSheet.Columns.Count).End(-4159).Column
'MaxCol = objSheet.Cells(1, 1).End(xlToRight).Column
Dim SColNum
If strTitle = "プルーフリスト" Then
SColNum = 2
ElseIf strTitle = "事例表示６" Then
SColNum = 1
End If
If SColNum <> "" Then
'objSheet.Range(objSheet.Cells(1,1),objSheet.Cells(MaxRowNum,MaxColNum)).Sort key1:=Range("C2"), order1:=xlAscending, header:=xlYes
'Set rrr = objSheet.Range(objSheet.Cells(1, 1), objSheet.Cells(20, 5))
Set rrr = objSheet.Cells(1, 1).Resize(MaxRowNum,MaxColNum)
rrr.Sort objSheet.Cells(1, SColNum), 1, , , , , , 1, 1, False, 1, 1, 0
'Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3
End If
strSaveFile =strFolder & "\" & LEFT(strDataFile,LEN(strDataFile)-4) & ".xlsx"
objExcel.Workbooks(1).SaveAs (strSaveFile)
'--3秒待つ
WScript.Sleep(3000)
'--Excel終了
objExcel.Quit
'--Excelオブジェクトクリア
Set objExcel = Nothing
End If
'終了処理－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'オブジェクトの破棄
Set objWFile = Nothing
Set objFSO = Nothing
Set objRE = Nothing
Set objRFile = NoThing
'終了メッセージ表示－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
WScript.Echo count-TitleRow & "件の処理が終了しました。" & vbCrLf & vbCrLf & _
"結果は、以下のファイルに保存されました。" & vbCrLf & vbCrLf & _
strSaveFile
'エラー処理－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
If Err.Number <> 0 Then
WScript.Echo ""
WScript.Echo "### 予期しないエラーが発生しました。 ###" & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラー詳細：" & Err.Description
'エラー情報をクリアする
Err.Clear
Dim strInp
WScript.Echo ""
WScript.Echo "何かキーを押すと終了します。"
strInp = WScript.StdIn.ReadLine
End If
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
|