初めに

Excelのデータを直接DBに登録するマクロです。
仕事でExcelでテストデータを作り、毎回ツールでコピペしていたので自動化しました。
まだまた、改良・考慮の余地はあります。

##環境
OS：Windows10Pro 64bit
Office：Office2013 64bit※
※Microsoftでは32bit版の利用を推奨しているようです。
PostgreSQL ODBC：psqlodbc_10_03_0000-x64
　PostgreSQLむけODBCドライバ
ODBC設定：64bit版
　コントロールパネル->管理ツール-> ODBC データソース (64 ビット)
※Officeが32bit版の場合、ODBCも32bit版をインストールしてください。

ライブラリの参照設定は以下のようにしました、新規に参照したのは下二つです。

##Excelのシート
item_mstにフォーカスし、マクロを実行するだけです。

##コード
パラメータのシングルクォーテーションとNULL考慮

Function getTypeVal(val As String, columnDataType As String)

getTypeVal.vba

 
    If val = Cells(1, 1) Then
        getTypeVal = "null"
    Else
        If columnDataType = "char" Then
            getTypeVal = "'" & val & "'"
        Else
            getTypeVal = val
        End If
    End If

Function getSheetData()

getSheetData.vba


    Dim 現在行 As Long
    Dim 現在列 As Long
    現在行 = Selection.Row
    現在列 = Selection.column
    Dim データ開始行 As Long
    Dim データ開始列 As Long
    Dim データ終了行 As Long
    Dim データ終了列 As Long
    Dim カラム行 As Long
    データ開始行 = 2 + 現在行
    データ開始列 = 現在列
    カラム行 = 1 + 現在行
    データ終了行 = Selection.End(xlDown).Row
    データ終了列 = Cells(カラム行, 現在列).End(xlToRight).column
    Dim DataBase() As Variant
    DataBase = Range(Cells(データ開始行, データ開始列), Cells(データ終了行, データ終了列))
    getSheetData = DataBase

Sub insertTable()

insertTable

    Dim テーブル名 As String
    Set c = Selection
    テーブル名 = Trim(c.value)
    
    If テーブル名 = "" Then
        MsgBox "テーブル名を指定してください。"
        Exit Sub
    End If
    
    Dim DataBase() As Variant
    DataBase = getSheetData()
    '行数
    Dim RowNum As Double
    '列数
    Dim ColNum As Double

    RowNum = UBound(DataBase, 1)                    '行数取得
    ColNum = UBound(DataBase, 2)                    '列数取得

    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = "DSN=local_PostgreSQL;"
    cn.Open

    ' ADOレコードセットを生成
    Dim objRS As ADODB.Recordset
    Set objRS = New ADODB.Recordset
    
   Dim infoSql As String
   infoSql = getDataType(テーブル名)
    'テーブル情報取得
    objRS.Open infoSql, cn
    '配列に入れ替え
    ReDim columnTypes(ColNum - 1) As String
    Dim i As Integer
    Do Until objRS.EOF
        columnTypes(i) = objRS(0).value
        i = i + 1
       objRS.MoveNext
    Loop
    If i = 0 Then
        MsgBox "テーブルが存在しません。"
        Exit Sub
    End If

    Dim sql As String
    sql = getInsertSQL(テーブル名, DataBase, columnTypes)
    'トランケート
    cn.Execute ("truncate table item_mst")
    'インサート
    cn.Execute sql
    objRS.Close
    Set objRS = Nothing
    cn.Close
    Set cn = Nothing

Function getInsertSQL(テーブル名 As String, DataBase As Variant, ByRef columnDataTypes() As String)

getInsertSQL

    Dim sql As String
    sql = "insert into " & テーブル名 & " values "
    'ループ変数
    Dim i As Double
    Dim j As Double
    '行数
    Dim RowNum As Double
    '列数
    Dim ColNum As Doubl
    RowNum = UBound(DataBase, 1)                    '行数取得
    ColNum = UBound(DataBase, 2)                    '列数取得
    Dim strTmp As String
    Dim value As String
    For i = 1 To RowNum
        If i <> 1 Then
            sql = sql + " , "
        End If
        sql = sql + " ( "
        For j = 1 To ColNum
            If j <> 1 Then
                sql = sql + " , "
            End If
            strTmp = DataBase(i, j)
            value = getTypeVal(strTmp, columnDataTypes(j - 1))
            sql = sql + value
         Next
          sql = sql + " )"
    Next
   getInsertSQL = sql

Function getDataType(tableName As String)

getDataType

    Dim sql As String
    sql = ""
    sql = sql + " SELECT case when  A1.data_type LIKE 'char%' THEN 'char' ELSE 'other' END  AS column_data_type "
    sql = sql + " FROM   information_schema.columns A1"
    sql = sql + " WHERE  A1.table_name = '" & tableName & "'"
    sql = sql + " ORDER  BY A1.ordinal_position"
    getDataType = sql