ExcelからAccessテーブルを作成するマクロ

Option Explicit

Const ROW_COLUMN_NAME = 2
Const ROW_DATA_TYPE = 3
Const ROW_PRIMARY_KEY = 4
Const ROW_FOREIGN_KEY = 5
Const ROW_NOT_NULL = 6
Const ROW_DEFAULT = 7
Const ROW_DESCRIPTION = 8
Const ROW_RECORDS = 11

Dim cnn As ADODB.Connection
Dim cat As ADOX.Catalog


Sub setupTables()

    Dim dbname As String, mySheet As Worksheet

    dbname = ThisWorkbook.Sheets("Setting").Range("B11")
    Call connectDB(dbname)

    For Each mySheet In ThisWorkbook.Worksheets
        If mySheet.Range("A1").Value = "[Table]" Then
            Call setupTable(mySheet)
            Call setupRecords(mySheet)
        End If
    Next

    Call disconnectDB

End Sub


Private Sub setupTable(mySheet As Worksheet)

    Dim myTable As New Table, tableName As String, msg As String, ans

    tableName = mySheet.Name

    If isExistTable(mySheet.Name) Then
        msg = "Table """ + mySheet.Name + """ already exists."
        msg = msg & vbCrLf & "Drop this table?"
        msg = msg & vbCrLf
        msg = msg & vbCrLf & "Yes => Drop and Create"
        msg = msg & vbCrLf & "No  => Update"

        ans = MsgBox(msg, vbYesNoCancel)
        If ans = vbYes Then
            Call dropTable(mySheet.Name)
            Call createTable(mySheet)
        End If
    Else
        Call createTable(mySheet)
    End If

End Sub


Private Function isExistTable(tableName As String)

    Dim myTable As ADOX.Table

    isExistTable = False
    For Each myTable In cat.Tables
        If LCase(myTable.Type) = "table" And myTable.Name = tableName Then
            isExistTable = True
            Exit For
        End If
    Next

End Function


Private Sub dropTable(tableName As String)

    Dim myTable As ADOX.Table, myKey As ADOX.Key

    For Each myTable In cat.Tables
        For Each myKey In myTable.Keys
            If myKey.Type = adKeyForeign Then
                If myKey.RelatedTable = tableName Then
                    Call myTable.Keys.Delete(myKey.Name)
                End If
            End If
        Next
    Next

    Call cat.Tables.Delete(tableName)

End Sub



Private Sub createTable(mySheet As Worksheet)

    Dim myTable As New ADOX.Table, colIndex As Long

    myTable.Name = mySheet.Name
    Set myTable.ParentCatalog = cat

    For colIndex = 2 To Columns.Count
        If mySheet.Cells(ROW_COLUMN_NAME, colIndex).Value = "" Then Exit For
        Call addColumn(myTable, mySheet.Columns(colIndex))
    Next

    Call cat.Tables.Append(myTable)


    If WorksheetFunction.CountIf(mySheet.Rows(ROW_PRIMARY_KEY), True) > 0 Then
        Call setPrimaryKey(myTable, mySheet)
    End If

    If WorksheetFunction.CountIf(mySheet.Rows(ROW_FOREIGN_KEY), "*") > 1 Then
        Call setForeignKey(myTable, mySheet)
    End If

End Sub

Private Sub addColumn(myTable As ADOX.Table, mySetting As Range)

    Dim myDataType As String, myDataTypeNum As ADOX.DataTypeEnum
    Dim myCol As ADOX.Column, myColName As String
    Dim prop As ADOX.Property, propKey As String


    myColName = mySetting.Cells(ROW_COLUMN_NAME, 1).Value
    myDataType = mySetting.Cells(ROW_DATA_TYPE, 1).Value
    myDataTypeNum = getDataType(myDataType)

    Call myTable.Columns.Append(myColName, myDataTypeNum)
    Set myCol = myTable.Columns(myColName)

    For Each prop In myCol.Properties
        propKey = LCase(prop.Name)

        If LCase(propKey) = "autoincrement" And LCase(myDataType) = "autonumber" Then
            prop.Value = True

        ElseIf LCase(propKey) = "nullable" And mySetting.Cells(ROW_NOT_NULL, 1).Value Then
            prop.Value = False

        ElseIf LCase(propKey) = "default" And mySetting.Cells(ROW_DEFAULT, 1).Value <> "" Then
            If myDataTypeNum = adDate Then
                prop.Value = "#" & mySetting.Cells(ROW_DEFAULT, 1).Value & "#"
            Else
                prop.Value = mySetting.Cells(ROW_DEFAULT, 1).Value
            End If

        ElseIf LCase(propKey) = "description" And mySetting.Cells(ROW_DESCRIPTION, 1).Value <> "" Then
            prop.Value = CStr(mySetting.Cells(ROW_DESCRIPTION, 1).Value)

        End If
    Next

End Sub


Private Sub setPrimaryKey(myTable As ADOX.Table, mySheet As Worksheet)

    Dim myIndex As New ADOX.Index, colIndex As Long

    myIndex.Name = "PK"
    myIndex.PrimaryKey = True

    For colIndex = 2 To Columns.Count
        If mySheet.Cells(ROW_COLUMN_NAME, colIndex).Value = "" Then Exit For
        If mySheet.Cells(ROW_PRIMARY_KEY, colIndex).Value Then
            Call myIndex.Columns.Append(mySheet.Cells(ROW_COLUMN_NAME, colIndex).Value)
        End If
    Next

    Call myTable.Indexes.Append(myIndex)

End Sub


Private Sub setForeignKey(myTable As ADOX.Table, mySheet As Worksheet)

    Dim myKey As ADOX.Key, colIndex As Long, colName As String
    Dim parts, toTableName As String, toColName As String

    For colIndex = 2 To Columns.Count
        colName = mySheet.Cells(ROW_COLUMN_NAME, colIndex).Value
        If colName = "" Then Exit For
        If mySheet.Cells(ROW_FOREIGN_KEY, colIndex).Value <> "" Then

            Set myKey = New ADOX.Key
            myKey.Name = colName
            myKey.Type = adKeyForeign
            Call myKey.Columns.Append(colName)

            parts = Split(mySheet.Cells(ROW_FOREIGN_KEY, colIndex).Value, ".")
            toTableName = parts(0)
            toColName = parts(1)

            myKey.RelatedTable = toTableName
            myKey.Columns(colName).RelatedColumn = toColName

            Call myTable.Keys.Append(myKey)
        End If
    Next

End Sub





Private Sub setupRecords(mySheet As Worksheet)

    Dim rowIndex As Long

    For rowIndex = ROW_RECORDS To Rows.Count
        If WorksheetFunction.CountA(mySheet.Cells(rowIndex, 2).Resize(1, Columns.Count - 1)) = 0 Then Exit For

        If isExistData(mySheet, rowIndex) Then
            Call updateData(mySheet, rowIndex)
        Else
            Call insertData(mySheet, rowIndex)
        End If
    Next

End Sub


Private Function isExistData(mySheet As Worksheet, rowIndex As Long)

    Dim myRecord As New ADODB.Recordset, myCondition As String

    Call myRecord.Open(mySheet.Name, cnn, adOpenForwardOnly, adLockReadOnly)

    myCondition = getSearchConditionPK(mySheet, rowIndex)
    myRecord.Filter = myCondition

    isExistData = (Not myRecord.EOF)

End Function


Private Function getSearchConditionPK(mySheet As Worksheet, rowIndex As Long)

    Dim parts(), pkIndex As Long, colIndex As Long, colName As String

    pkIndex = 1
    ReDim parts(1 To pkIndex)

    For colIndex = 2 To Columns.Count
        colName = mySheet.Cells(ROW_COLUMN_NAME, colIndex)
        If colName = "" Then Exit For

        If mySheet.Cells(ROW_PRIMARY_KEY, colIndex) Then
            ReDim Preserve parts(1 To pkIndex)
            parts(pkIndex) = colName & "=" & getSQLValue(mySheet, rowIndex, colIndex)
            pkIndex = pkIndex + 1
        End If
    Next

    getSearchConditionPK = Join(parts, " AND ")

End Function


Private Sub updateData(mySheet As Worksheet, rowIndex As Long)

    Dim myRecord As New ADODB.Recordset, myCondition As String
    Dim colName As String, colIndex As Long

    Call myRecord.Open(mySheet.Name, cnn, adOpenForwardOnly, adLockOptimistic)

    myCondition = getSearchConditionPK(mySheet, rowIndex)
    myRecord.Filter = myCondition

    For colIndex = 2 To Columns.Count
        colName = mySheet.Cells(ROW_COLUMN_NAME, colIndex)
        If colName = "" Then Exit For

        If mySheet.Cells(rowIndex, colIndex) <> "" And Not mySheet.Cells(ROW_PRIMARY_KEY, colIndex) Then
            myRecord.Fields(colName).Value = mySheet.Cells(rowIndex, colIndex)
        End If
    Next

    Call myRecord.Update

End Sub


Private Sub insertData(mySheet As Worksheet, rowIndex As Long)

    Dim myRecord As New ADODB.Recordset, colIndex As Long
    Dim colName As String

    Call myRecord.Open(mySheet.Name, cnn, adOpenKeyset, adLockOptimistic)

    Call myRecord.AddNew

    For colIndex = 2 To Columns.Count
        colName = mySheet.Cells(ROW_COLUMN_NAME, colIndex)
        If colName = "" Then Exit For

        If mySheet.Cells(rowIndex, colIndex) <> "" Then
            myRecord.Fields(colName).Value = mySheet.Cells(rowIndex, colIndex)
        End If
    Next

    Call myRecord.Update

End Sub




Private Sub connectDB(dbname As String)
    Set cnn = New ADODB.Connection
     cnn.Provider = "Microsoft.Ace.OLEDB.12.0"
    cnn.Open dbname
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = cnn
End Sub

Private Sub disconnectDB()
    Set cat = Nothing
    cnn.Close
    Set cnn = Nothing
End Sub

Private Function getSQLValue(mySheet As Worksheet, rowIndex As Long, colIndex As Long)

    Dim dataType As String, sql As String

    dataType = LCase(mySheet.Cells(ROW_DATA_TYPE, colIndex))
    sql = mySheet.Cells(rowIndex, colIndex)

    If dataType = "date" Then
        sql = "#" & mySheet.Cells(rowIndex, colIndex) & "#"

    ElseIf dataType = "text" Then
        sql = "'" & mySheet.Cells(rowIndex, colIndex) & "'"
    End If

    getSQLValue = sql

End Function

Private Function getDataType(dirtyDataType)

    Dim dataTypeNum As ADOX.DataTypeEnum

    dataTypeNum = adVarWChar
    dirtyDataType = LCase(dirtyDataType)

    If dirtyDataType = "text" Then dataTypeNum = adVarWChar
    If dirtyDataType = "integer" Then dataTypeNum = adInteger
    If dirtyDataType = "double" Then dataTypeNum = adDouble
    If dirtyDataType = "currency" Then dataTypeNum = adCurrency
    If dirtyDataType = "date" Then dataTypeNum = adDate
    If dirtyDataType = "boolean" Then dataTypeNum = adBoolean
    If dirtyDataType = "autonumber" Then dataTypeNum = adInteger

    getDataType = dataTypeNum

End Function