EXCELからACCESSに登録

EXCELからACCESSに登録する部分。
チェックロジックの中に色々と詰め込む。
何となく気に入らない作りながら仕方がない。
今後、色々と見直しする。

Function ExcelToAccess(val_ExcelPath,val_AccessPath,val_EmpDate)
    Dim cn, rs            'ACCESSデータベース
    Dim objExcel        'EXCEL
    Dim xlSheet
    Dim objFso            'ファイル存在チェック用
    Dim argRtn(3)        '引数チェック用   
    Dim DataBaseName
    Dim strSQL
    Dim ExcelName
    Dim EmpDate            '現在日付取得(登録日日算出)
    Dim keyDate           
    Dim OpFlg           
    Dim i            'ループカウンタ(タイトル行除外スタート)
    Dim j             '処理件数カウント用
    Dim LastRow            'EXCELL最終行
    Dim KeyCell            'EXCEL行NO(抽出条件ヒット用
    Dim KeyOpFlgCell        '手動除外用
    Dim CellValue        '格納用ワーク
    Dim strEmpCol   
    strEmpCol ="X"         'EXCELの列
    Dim strOpCol   
    strOpCol ="XX"        'EXCELの列
    Dim rsCount            'レコード件数カウント用
    Dim EmpMCclum       
    EmpMCclum = "X"       
    Dim InputArea       
    Dim InputDate        '
    InputDate = Mid(Now(),6,5) & "XX"

    Dim InEmpNo           
    Dim InName           
   
    Dim NoCell           
    Dim NameCell

    Dim oColum1           
    Dim oColum2           

    '--------------------------------------------------------------
    '/* 引数エラーチェック
    argRtn(0)= argumentChecker(val_ExcelPath)
    argRtn(1)= argumentChecker(val_AccessPath)
    argRtn(2)= argumentChecker(val_EmpDate)
   
    If argRtn(0) ="False" Or argRtn(1) ="False" Or argRtn(2)="False" Then
        ExcelToAccess = "False"
        Logrtn = OutLogger("[Err],ファイル名もしくは日付が空欄です。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
        Exit Function
    Else
        DataBaseName = val_AccessPath
        ExcelName = val_ExcelPath
        EmpDate = CDate(val_EmpDate)
    End If
   
    '//* ACCESSデータベースファイル存在チェック
    Set objFso = CreateObject("Scripting.FileSystemObject")
    If objFso.FileExists(DataBaseName) Then
        Set cn = CreateObject("ADODB.Connection")
        cn.CursorLocation = 3                     ' クライアントサイドカーソルに変更(レコードセットカウント対策)
        cn.Open "Provider = Microsoft.ACE.OLEDB.12.0; " & _
        "Data Source = " & DataBaseName & ";"
        Set rs = CreateObject("ADODB.Recordset")
    Else
        ExcelToAccess = "False"
        WScript.Echo CErrMsg
        Logrtn = OutLogger("[Err],ACCESSデータベースが存在しません。ACCESSデータベースを確認してください。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
        Set objFso = Nothing
        Exit Function
    End If
    Set objFso = Nothing
   
    '//* EXCELファイル存在チェック
    Set objFso = CreateObject("Scripting.FileSystemObject")
    If objFso.FileExists(ExcelName) Then
        Set objExcel = CreateObject("Excel.Application")
        objExcel.Workbooks.Open(ExcelName)
        Set xlSheet = objExcel.Worksheets(1)
        objExcel.Visible = False
    Else
        ExcelToAccess = "False"
        Logrtn = OutLogger("[Err],EXCELファイルが存在しません。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
        Set objFso = Nothing
        Exit Function
    End If
    Set objFso = Nothing
    '
    LastRow = xlSheet.UsedRange.Rows.Count    'EXCEL最終行取得
    j=0                                        '処理件数初期化
    For i = 5 To LastRow Step 1
        'DoはContinue対応用ループ
        '(http://mblog.excite.co.jp/user/yozda/entry/detail/?id=9314000)
        Do

            KeyCell = strEmpCol & i
            keyDate = xlSheet.Range(keyCell).Value
            KeyOpFlgCell = strOpCol & i
            OpFlg = xlSheet.Range(KeyOpFlgCell).Value
           
            If keyDate > EmpDate And InStr(OpFlg,"XX")=0 Then
                '/* 日が合致した行のデータを取得 */
                NoCell =     "X" & i
                NameCell=     "X" & i
               
                oColum1=xlSheet.Range(NoCell).Value
                oColum2=xlSheet.Range(NameCell).Value
               
                '/* チェックロジック */
               
                '/* チェックロジック */
               
                '/*  ACCESSデータベースへの登録 */
                'ACCESSデータベースへの接続
                strSQL=""
                strSQL= strSQL & " INSERT INTO ACCESSデータベース( "
                strSQL= strSQL & "  )"
                strSQL= strSQL & " VALUES ( "
                strSQL= strSQL & "'" &  oColum1 & "'" & ", "
                strSQL= strSQL & "'" &  oColum2 & "'"
                strSQL= strSQL & " );"
               
                cn.BeginTrans                'トランザクション開始
                Set rs =cn.Execute(strSQL)
                If Err.Number = 0 Then
                    cn.CommitTrans                    'コミット
                Else
                    ExcelToAccess = "False"
                    objADO.RollbackTrans            'ロールバック
                    Logrtn = OutLogger("[Err],"& oEmpNo & ":" & oName & "ACCESSデータベースの追加に失敗しました。手動で処理してください。")
                    If Logrtn = "False" Then
                        WScript.Echo LErrMsg
                    End If
                    Exit Do
                End If
               
                '/*  EXCEL登録/
                '日付をセットする。
                InputArea = EmpMCclum & i
                CompArea = strOpCol & i
                xlSheet.Range(InputArea).Value = InputDate
                xlSheet.Range(CompArea).Value = "XX"
                'EXCELを保存
                objExcel.DisplayAlerts = False
                objExcel.Workbooks(1).Save
               
                j=j+1
            End If
        Loop Until 1
    Next
   
    If j=0 Then
        ExcelToAccess = "False"
        Exit Function
    End If
    Logrtn = OutLogger("[Comp],ACCESSデータベース登録完了者" & j & "件です")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
   
    objExcel.DisplayAlerts = False
    objExcel.Application.Quit       
    Set rs = Nothing
    Set cn = Nothing
    ExcelToAccess = "True"
   
End Function