Create Access database and load new table from CSV.

I was trying to find an example of this earlier and didn't, so I rolled my own. I wanted to share it for anyone else on the web looking. I wrote it in Excel VBA, but I suppose it could work in general VB.

It essentially takes any random CSV with a (1st) row of unique titles and builds an access database with a single table.

Requirements:

• you need a db name (an accdb extension)
• the CSV header (1st row) will be field names, spaces replaced with underscores. (I know some people say underscores are bad, but I don't think they're used to working with real databases (Oracle, et, al) . ;) )
• I run this on Excel 2016, YMMV with your version.
• Replace the "Newest_File" function with your CSV file name or equivalent. (that function wasn't written by me so I didn't want to post someone elses work).

Also note that this sub:

• I wrote this to blow away my old access db and build fresh. Be aware, it deletes first.
• Makes all columns strings. You can tweak it to figure out numbers if you like.
• It looks at the max value of each column to determine the size to make it. If a column is all blank, size will be 1.
• It adds a "dummy" field at the end which just saves me some formatting code (I was lazy).
• Change the table to fit your needs. I made mine 'assets'.
• The ParseString function is one of my favorites. I wrote it 17 years ago and still use it. There may be a modern equivalent that I don't know about.
• I didn't make this thing "perfect" and commented for this posting, but it does what I need.

Hope it helps someone.
-Jeff

Code:

---

Sub CreateDB(dbPath As String)

  Dim dbConnectStr As String
  Dim Catalog As Object
  Dim cnt As Object

    BuildLog ("Rebuilding Database from CSV File")


    dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath & ";"

    BuildLog ("    Deleting old database")
    On Error Resume Next
    Kill dbPath
    On Error GoTo 0

  Dim dbs As Object
  Set dbs = CreateObject("ADOX.Catalog")
  dbs.Create "provider='Microsoft.ACE.OLEDB.12.0';Data Source=" & dbPath
  Set dbs = Nothing

   
    CSV_Path = "C:\Users\Jeff\Downloads\"
    CSV_File = CSV_Path & NewestFile("C:\Users\Jeff\Downloads", "asset*.csv")
    BuildLog ("    Opening Source file " & CSV_File)

    iFileNum = FreeFile()
    Open CSV_File For Input As iFileNum

    Line Input #iFileNum, strFields
    i = 0
    Do While 1 = 1
      i = i + 1
      strField = ParseString(strFields, ",", i)
      If strField = "" Then
        intFldCnt = i - 1
        Exit Do
      End If
    Loop
    Dim arrFields() As String
    Dim arrSizes() As Integer
    ReDim arrFields(intFldCnt)
    ReDim arrSizes(intFldCnt)
    For i = 1 To intFldCnt
      strField = Replace(ParseString(strFields, ",", i), " ", "_")
      arrFields(i) = strField
    Next

    intRowCnt = 0
    Dim arrValues()
    ReDim arrValues(500, intFldCnt)
    Do While Not EOF(iFileNum)
      intRowCnt = intRowCnt + 1
      Line Input #iFileNum, CSV_Row_Line
      For j = 1 To intFldCnt
        arrValues(intRowCnt, j) = Replace(ParseString(CSV_Row_Line, ",", j), "'", "''")
      Next
    Loop

    ' Get the max length of each column, so we know what arrSizes to make our columns
    Close iFileNum
    For intCol = 1 To intFldCnt
      For intRow = 1 To intRowCnt
        If Len(arrValues(intRow, intCol)) > arrSizes(intCol) - 1 Then ' the -1 BS has it evaluate those of zero len, so we get at least 1
          arrSizes(intCol) = Len(arrValues(intRow, intCol)) + 1
        End If
      Next
    Next
    strCreateTbl = "CREATE TABLE ASSETS ("
    For intCol = 1 To intFldCnt
      strCreateTbl = strCreateTbl & "[" & arrFields(intCol) & "] text(" & arrSizes(intCol) & "), "
    Next
    strCreateTbl = strCreateTbl & "[dummy] text(1) ) "
 
    'Open the database and create the table
    Set cnt = CreateObject("ADODB.Connection")
    cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & dbPath & ";"
    cnt.Execute strCreateTbl
   

    'Insert data into our tables
    For intRow = 1 To intRowCnt
      strInsertStmt = "INSERT INTO ASSETS VALUES("
      For intCol = 1 To intFldCnt
        strInsertStmt = strInsertStmt & "'" & arrValues(intRow, intCol) & "',"
      Next
      strInsertStmt = strInsertStmt & "'X')"
      cnt.Execute strInsertStmt
    Next


Set cnt = Nothing
End Sub

Public Function ParseString(InString, Delimchar, SegPosition)

  PosCnt = 0
  Pos1 = 1
  Do While PosCnt <= SegPosition
    PosCnt = PosCnt + 1
    Pos2 = Pos1
    Pos2 = InStr(Pos1, InString & Delimchar, Delimchar)
    If Pos2 > 0 Then
        If PosCnt = SegPosition Then
          OutString = Mid(InString, Pos1, (Pos2 - Pos1))
          Exit Do
        End If
      Pos1 = Pos2 + 1
    Else
      OutString = ""
      Exit Do
    End If
  Loop
  ParseString = OutString

End Function

---