ACCESS でCSV出力ツール作ってみた（その3）

- 5月 24, 2010
この辺りはNETで調べれば出てくるんでまあ掲載の必要もないですが・・・・
参考までに・・・・。EXCELのインポートとエクスポート部分です。
Function FromExcel(strTableName As String, strImportTableName As String, strXlsFileName As String, strSheet As String)
'====================================================================
' テーブルから定義情報を取得してインポートする。
' 可変EXCEL(カラム追加の可能性のあるテーブル)インポート関数
' 2010.05.19 Created By M.Nishimura
'＊使い方
'  str_rtn = FromExcel(定義テーブル名,取込テーブル名,EXCELファイル名)
'＊戻り値
'　True：処理正常終了
'　False：処理失敗
'
'====================================================================
    Const COLUMCNT = 256                            'カラム数
   
    Dim db_Dao(1) As DAO.Database
    Dim Rst_Dao(1) As DAO.Recordset
    Dim Qdf_Dao As DAO.QueryDef
    Dim xls As Excel.Application
    Dim wkb As Excel.Workbook
    Dim vntList As Variant                     'EXCELのセル数値取得
   
    Dim strTname As String                     '定義テーブル名
    Dim striTname As String                    'インポート先テーブル名
    Dim strFlName As String                    '取込ファイル名
    Dim strSheetName As String                 'シート名

    Dim dbsCurrent As DAO.Database
    Dim strSQL As String
    Dim tdfNew As DAO.TableDef
    Dim tdffld(COLUMCNT) As DAO.Field

    Dim strClum(COLUMCNT) As String
    Dim strFieldName(COLUMCNT) As String       'フィールド名(カラム数分の配列)
    Dim strFieldSize(COLUMCNT) As String       'フィールドサイズ(カラム数分の配列)
    Dim intFieldSize(COLUMCNT) As Integer      'フィールドサイズ(カラム数分の配列)
    Dim balRetTableExists As Boolean
   
    Dim i As Integer                'レコードカウント用
    Dim j As Integer                'カラム数
    Dim k As Integer                'カラム比較用
    Dim CNT As Long                 'EXCEL用
   
    Dim ExSheetCount As Integer         'EXCELシート取得
    Dim ArrSheets() As String           'EXCELシート名格納
    Dim strSheetCheck As String         'EXCELシートチェック結果
   
    strTname = strTableName
    striTname = strImportTableName
    FromExcel = "False"
    strFlName = strXlsFileName
    strSheetName = strSheet
    
'ワークテーブルの存在を確認した後,ワークテーブルが存在すればワークテーブル削除
    balRetTableExists = TableOparate.TableExists(striTname)
    If balRetTableExists = True Then
        DoCmd.DeleteObject acTable, striTname
    End If
    
'呼出しテーブル定義
    strSQL = ""
    strSQL = strSQL & " SELECT " & strTname & ".*"
    strSQL = strSQL & " FROM "
    strSQL = strSQL & strTname & ";"
    strSQL = strSQL & ""

'    'デバッグ用
'    Debug.Print strSQL

    Set db_Dao(0) = CurrentDb
    Set Qdf_Dao = db_Dao(0).CreateQueryDef("", strSQL)
    Set Rst_Dao(0) = Qdf_Dao.OpenRecordset()
   
   
'新規テーブル作成用
    Set dbsCurrent = CurrentDb
    Set tdfNew = dbsCurrent.CreateTableDef(striTname)

    i = Rst_Dao(0).RecordCount
   
'レコード数取得
    If i <> 0 Then
        Rst_Dao(0).MoveLast
        j = Rst_Dao(0).RecordCount
        Rst_Dao(0).MoveFirst
    End If
       
    k = 0
'//**　テーブル作成(テーブルを新規作成<カラムは可変(全てテキスト型)>)　**
    Do Until k = j
        strFieldName(k) = Nz(Rst_Dao(0).Fields(2))  'フィールド名
        strFieldSize(k) = Nz(Rst_Dao(0).Fields(3))  'フィールドサイズ
        intFieldSize(k) = CInt(strFieldSize(k))
       
        Set tdffld(k) = tdfNew.CreateField(strFieldName(k), dbText, intFieldSize(k))
        tdffld(k).AllowZeroLength = True '空文字列の許可
        tdfNew.Fields.Append tdffld(k)
       
        Rst_Dao(0).MoveNext
        k = k + 1
    Loop

    tdfNew.Fields.Refresh
    dbsCurrent.TableDefs.Append tdfNew
    dbsCurrent.TableDefs.Refresh
    dbsCurrent.Close
   
    Set db_Dao(1) = CurrentDb
    Set Rst_Dao(1) = db_Dao(1).OpenRecordset(striTname, dbOpenTable)

'//**　EXCEL取込　****
    Set xls = CreateObject("Excel.Application")
    Set wkb = xls.Workbooks.Open(Filename:=strFlName, ReadOnly:=True)
   
     'シート名を指定したい場合は関数呼出し時にシート名をセット
    If strSheetName = "" Or strSheetName = Null Then
        strSheetName = InputBox("Excelファイルのシート名を記述します。", , "Sheet1")
    End If
   
    'シート名の存在チェック
    ExSheetCount = xls.Worksheets.Count
    ReDim ArrSheets(ExSheetCount - 1)               '配列変数再定義
   
    For i = 1 To ExSheetCount                        'シートのチェック
        ArrSheets(i - 1) = xls.Worksheets(i).Name
        If strSheetName = ArrSheets(i - 1) Then
            strSheetCheck = "True"
            Exit For
        End If
    Next i
   
    If strSheetCheck = "True" Then
        '読み込み開始位置セット
        With wkb.Worksheets(strSheetName).Range("A2").CurrentRegion
            vntList = .Resize(.Rows.Count - 1).Offset(1, 0).Value
        End With
    Else
        wkb.Close SaveChanges:=False
        xls.Quit
        Set wkb = Nothing
        Set xls = Nothing
        Exit Function
    End If
       
    wkb.Close SaveChanges:=False
    xls.Quit
    Set wkb = Nothing
    Set xls = Nothing
       
    '//*　データ読込部(データが存在する間中データ読込)
    For CNT = LBound(vntList, 1) To UBound(vntList, 1)
        i = 0
        Rst_Dao(1).AddNew
        Do Until i = j
            Rst_Dao(1).Fields(i).Value = vntList(CNT, i + 1)        'i+1としているのはセルが1から開始のため
            i = i + 1
        Loop
        Rst_Dao(1).Update
    Next

'* DBのクローズ
    Rst_Dao(0).Close
    db_Dao(0).Close
    Rst_Dao(1).Close
    db_Dao(1).Close

    FromExcel = "True"
    Exit Function


'//*　エラー処理　*//
ERROR_SUB:
   
    MsgBox "Error番号：" & Err.Number & vbNewLine & _
            "Error内容：" & Err.Description, 16, "管理者"
   
    FromExcel = "False"
   
    xls.Quit
    Set wkb = Nothing
    Set xls = Nothing

    Exit Function

End Function
Function ToExcel(StrDataName As String, StrFileName As Variant, strSheetName As String) As String
'====================================================================
' EXCELデータエクスポート
' 2010.05.19 Updated By M.Nishimura
'＊使い方
'  str_rtn = ToExcel(出力元テーブル名,出力先EXCELファイル,出力先シート名)
'＊戻り値
'　True：処理正常終了
'　False：処理失敗
'
'====================================================================
On Error GoTo err_a

    Const FIRSTG = 2                 'EXCEL行初期値
    Const FIRSTR = 1                 'EXCEL列初期値

    Dim db_Dao As DAO.Database
    Dim Rst_Dao As DAO.Recordset
   
    Dim xls As Excel.Application
    Dim wkb As Excel.Workbook
   
    Dim strMsg As String
    Dim varinput1, varinput2, varinput3 As Variant
    Dim lngGcnt As Long                               'EXCEL行数用カウンタ
    Dim lngRcnt As Long                               'EXCEL列数用カウンタ
    Dim i As Integer               '出力テーブルフィールドカウント用
    Dim j As Integer               '最終フィールド数
    Const CORUM = 0                'データ部フィールドカウンタの初期値
   
    Dim ExSheetCount As Integer         'EXCELシート取得
    Dim ArrSheets() As String           'EXCELシート名格納
    Dim strSheetCheck As String         'EXCELシートチェック結果
   
    Dim balRetTableExists As Boolean
   
   
    ToExcel = "False"
   
    '出力用テーブルチェック
    balRetTableExists = TableOparate.TableExists(StrDataName)
    If balRetTableExists = False Then
        Exit Function
    End If

    Set db_Dao = CurrentDb
   
    '出力元のテーブルまたはクエリ名です。
    varinput3 = StrDataName
    If varinput3 <> "" Then
        Set Rst_Dao = db_Dao.OpenRecordset(StrDataName)
    Else
        Exit Function
    End If

    'ファイル名指定
    varinput1 = StrFileName
   
    If IsNull(varinput1) Then End
    Set xls = CreateObject("Excel.Application")             'EXCELオブジェクト定義
    Set wkb = xls.Workbooks.Open(Filename:=varinput1)
   
'シート名の存在判定、入力されたシートが存在しない場合にはシートを追加する
    If strSheetName = "" Or strSheetName = Null Then
        varinput2 = InputBox("Excelファイルのシート名を記述します。", , "Sheet1")
    End If
   
    ExSheetCount = xls.Worksheets.Count
    ReDim ArrSheets(ExSheetCount - 1)               '配列変数再定義
   
    For i = 1 To ExSheetCount                        'シートのチェック
        ArrSheets(i - 1) = xls.Worksheets(i).Name
        If strSheetName = ArrSheets(i - 1) Then
            strSheetCheck = "True"
            Exit For
        End If
    Next i
   
    If strSheetCheck = "True" Then
        varinput2 = strSheetName
        xls.Worksheets(varinput2).Select
    Else
        '新規シートを最後尾に追加
        varinput2 = strSheetName
        wkb.Worksheets.Add after:=wkb.Worksheets(i - 1)
        wkb.Worksheets(i).Name = varinput2
    End If

'セルにデータを出力。(セルの行、セルの列)で位置指定
'レコードの終了までループ処理で繰り返し
   j = Rst_Dao.Fields.Count
   Rst_Dao.MoveFirst

'//　見出出力部分(1行目を見出しとする。)
    i = CORUM                  '行を進める際にACCESSテーブルのフィールド先頭にカウンタを戻す。
    lngRcnt = FIRSTR              'EXCELの列をA列にセット
   
    Do Until i >= j        'ACCESSテーブルのフィールド最終列まで繰り返してデータを出力
       xls.Cells(FIRSTR, lngRcnt).Value = Rst_Dao.Fields(i).Name
       i = i + 1
       lngRcnt = lngRcnt + 1
    Loop
   
'//　データ出力部分
    lngGcnt = FIRSTG
    Do Until Rst_Dao.EOF
        i = CORUM
        lngRcnt = FIRSTR
       
        Do Until i >= j       'データの値を出力
           xls.Cells(lngGcnt, lngRcnt).Value = Rst_Dao.Fields(i).Value
          
''**********文字数字混在で強制的に文字列出力したい場合はCORUMを制御したい列番号にしてコメント解除
''           If i = CORUM Then
''              xls.Cells(lngGcnt, lngRcnt).Value = "'" & Rst_Dao.Fields(i).Value
''           End If
''**********文字数字混在で強制的に文字列出力したい場合はCORUMを制御したい列番号にしてコメント解除
          
           i = i + 1
           lngRcnt = lngRcnt + 1
        Loop
       
        lngGcnt = lngGcnt + 1
        Rst_Dao.MoveNext '次レコードへ
    Loop
   
    wkb.Save              'セーブ時にEXCELのメッセージを表示しない
    wkb.Close False
    xls.Quit             'EXCEL開放
    Set Rst_Dao = Nothing
    Set db_Dao = Nothing
    ToExcel = "True"
    Exit Function
   
err_a:

    MsgBox "Error番号：" & Err.Number & vbNewLine & _
            "Error内容：" & Err.Description, 16, "管理者"
       
    wkb.Close False
    xls.Quit             'EXCEL開放
    Set Rst_Dao = Nothing
    Set db_Dao = Nothing
               
End Function
このブログを検索

オーバーフォーティーおやじログ

ACCESS でCSV出力ツール作ってみた（その3）

コメント

このブログの人気の投稿

証券外務員1種勉強(計算式暗記用メモ)

GASでGoogleDriveのサブフォルダとファイル一覧を出力する

マクロ経済学(IS-LM分析)
