Hello im new to VBA and im struggling a bit, so i need your help.
About the requirements: Every day a special csv file is updated by our CRM. From this Excel table 4 columns are to be written into a database. All contents of the cells are strings.
The table name in the SQL database should be the name of the respective worksheet. In the Excel table there are some cells which start with a " # ", " ' " or " _ ". The VBA code should ignore these when transferring to the database.
The VBA code should be adapted so that all new columns that are added over time are automatically recognized and written to the database. All contents of these columns are to be represented in the future also as string.
There will be several worksheets with time (currently 2), which the VBA code should run through automatically. However, the column names are not always identical from the worksheets. If there is a new worksheet, it should create this as a table in the database and run through exactly the same procedure.
With each new search run only changes should be transferred and no duplicate entries should be made.
This is my test code, which was working.
Option Explicit
Public cn As ADODB.Connection
Sub ProcessData()
Set cn = New ADODB.Connection
Dim rs As ADODB.Recordset
Dim StrSQL As String
Dim id As Integer
Dim Row number of Article As String
Dim SM001 As String
Dim SM004 As String
Dim SM013 As String
Dim strConn As String
strConn = "Driver={SQL Server};Server=Testserver2019; Database=Work2023; Trusted_Connection=yes"
Dim lastRow As Double
Dim row As Double
Dim ws As Integer
cn.Open strConn
StrSQL = "Truncate table dbo.MyTable"
cn.Execute StrSQL
For ws = 1 To Worksheets.Count
wsName = Worksheets(ws).Name
'MsgBox (wsName)
'activating each worksheet in order to iterate through data
Worksheets(wsName).Activate
'going to very first cell of worksheet to get last row to find out range
Cells(1, 1).Select
'fetching last row so that we can iterate through each & every cell
lastRow = Cells(Rows.Count, 1).End(xlUp).row
For row = 2 To lastRow
Row number of article = Cells(row, 1).Value
SM001 = Cells(row, 2).Value
SM004 = Cells(row, 3).Value
SM013 = Cells(row, 4).Value
StrSQL = "insert into dbo.MyTable(id, name, code, city) values(" _
+ Str(Row number of Article) + "," _
+ "'" + SM001 + "'," _
+ "'" + SM004 + "'," _
+ "'" + SM013 + "'" _
+ ")"
'MsgBox (StrSQL)
cn.Execute StrSQL
Next row
'MsgBox (StrSQL)
Next
cn.Close
Set cn = Nothing
MsgBox ("Process is finished...")
End Sub
Unfortunately these entries are still rendered with # , ' or _. Which is of course clear, since I don't have the condition in my VBA code yet. Hence the question can I do this with the command or is there a better way:
For row = 2 To lastRow
If Left(.Cells(row, 1).Value, 1) <> "#" And Left(.Cells(row, 1).Value, 1) <> "'" And Left(.Cells(row, 1).Value, 1) <> "_" Then
Row number of article = .Cells(row, 1).Value
SM001 = .Cells(row, 2).Value
SM004 = .Cells(row, 3).Value
SM013 = .Cells(row, 4).Value
Some more questions: How do I get the columns to be automatically recognized and written to the database?
How do I get Excel to run through all available worksheets and create them as a table in the database?
How do I make sure that it does not populate the table with duplicate entries each time, but only updates the tables during the next scan?
The VBA code should also intentionally take cells that are not yet filled as an empty field into the database.
How do I make sure that it does not populate the table with duplicate entries each time, but only updates the tables during the next scan? '. Delete any existing record with same primary key before inserting the new record.
Note : Records deleted from the spreadsheet won't be deleted from the database.
Edit 1 : Primary Key as BigInt
Option Explicit
Const PK = "Row number of article"
Public cn As ADODB.Connection
Sub ProcessData()
Set cn = DbConnect("TestServer2019", "Work2023")
Dim cmd As ADODB.Command, cmdDel As Command
Dim wb As Workbook, ws As Worksheet
Dim rs As ADODB.Recordset, sql As String, t As String
Dim n As Long, lastrow As Long, r As Long
Dim numIns As Long, numDel As Long
Dim msg As String, bExists As Boolean
Dim colField As Collection, t0 As Single: t0 = Timer
' build dictionary of existing tables in database
Dim dictTable As Object, k
Set dictTable = CreateObject("Scripting.Dictionary")
sql = "SELECT TABLE_NAME " & _
"FROM INFORMATION_SCHEMA.TABLES " & _
"WHERE TABLE_TYPE = 'BASE TABLE'"
Set rs = cn.Execute(sql)
Do While Not rs.EOF
t = rs.Fields(0)
rs.MoveNext
dictTable.Add t, 0
'msg = msg & vbLf & t
Loop
'MsgBox "Existing Tables " & msg
' loop through sheets
For Each ws In ThisWorkbook.Sheets
' does table exist
bExists = dictTable.exists(ws.Name)
If bExists = False Then
If ws.Cells(1, 1) = PK Then
sql = BuildCreateSQL(ws)
'If vbYes = MsgBox("Create Table " & ws.Name & vbLf & sql, vbYesNo, "Confirm") Then
'Debug.Print sql
cn.Execute sql
bExists = True ' table exists
'End If
Else
MsgBox ws.Name & " cell A1 must be " & PK, vbExclamation
End If
End If
' update records
If bExists = True Then
' build insert query
Set colField = New Collection
sql = BuildSQL(ws, colField)
'Debug.Print ws.Name, sql
' build insert command
Set cmd = New ADODB.Command
With cmd
.CommandText = sql
.ActiveConnection = cn
For n = 1 To colField.Count
If n = 1 Then
.Parameters.Append .CreateParameter("P" & n, adBigInt, adParamInput)
Else
.Parameters.Append .CreateParameter("P" & n, adVarChar, adParamInput, 255)
End If
Next
End With
' build delete command
Set cmdDel = New ADODB.Command
With cmdDel
.ActiveConnection = cn
.CommandText = "DELETE FROM dbo." & ws.Name & _
" WHERE [" & PK & "] = ?"
.Parameters.Append .CreateParameter("P" & n, adVarChar, adParamInput, 255)
End With
' scan down sheet deleting / inserting rows
With ws
lastrow = .Cells(.Rows.Count, 1).End(xlUp).row
For r = 2 To lastrow
' assign parameter values
For n = 1 To cmd.Parameters.Count
cmd.Parameters(n - 1).Value = NoHash(.Cells(r, colField(n)))
Next
' delete if existing and insert
cmdDel.Parameters(0).Value = .Cells(r, 1) ' primary key in col 1
cmdDel.Execute n
numDel = numDel + n
cmd.Execute n
numIns = numIns + n
Next
End With
Set cmd = Nothing
Set cmdDel = Nothing
Set colField = Nothing
End If
Next
cn.Close
Set cn = Nothing
MsgBox numDel & " records deleted" & vbLf & _
numIns & " records inserted", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Function BuildSQL(ws As Worksheet, ByRef colField) As String
Dim lastcol As Long, i As Long, ph As String, fname As String
Dim f As String, sql As String, sep As String
With ws
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To lastcol
fname = .Cells(1, i)
If Len(fname) > 0 Then
colField.Add i, fname ' column number
f = f & sep & "[" & fname & "]"
ph = ph & sep & "?" ' parameter placeholders
sep = ","
End If
Next
End With
BuildSQL = "INSERT INTO dbo." & ws.Name & _
" (" & f & ") VALUES (" & ph & ")"
End Function
Function BuildCreateSQL(ws As Worksheet) As String
Dim lastcol As Long, i As Long, fname As String
Dim f As String, sql As String, sep As String
With ws
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To lastcol
fname = .Cells(1, i)
If Len(fname) > 0 Then
If i = 1 Then
f = f & sep & "[" & fname & "]" & " bigint"
Else
f = f & sep & "[" & fname & "]" & " varchar(255)"
End If
sep = ","
End If
Next
End With
BuildCreateSQL = "CREATE TABLE dbo." & ws.Name & _
" (" & f & ", CONSTRAINT pk_" & Replace(ws.Name, " ", "_") & _
" PRIMARY KEY ([" & PK & "]))"
End Function
Function NoHash(s As String)
Select Case Left(s, 1)
Case "#", "_", "'"
NoHash = Mid(s, 2)
Case Else
NoHash = s
End Select
End Function
Function DbConnect(SERVER As String, DBNAME As String) As ADODB.Connection
Dim s As String
s = "Driver={SQL Server};Server=" & SERVER & _
";Database=" & DBNAME & "; Trusted_Connection=yes"
Set DbConnect = New ADODB.Connection
DbConnect.Open s
End Function
Update the selected cell
Sub UpdateCell()
If Selection.Count > 1 Then
MsgBox "Select only one cell"
Exit Sub
End If
Dim cmdUpd As ADODB.Command, sql As String, sValue As String
Dim sTable As String, sField As String, uid As Long
With ActiveSheet
sTable = .Name
sField = .Cells(1, Selection.Column)
sValue = NoHash(Selection.Value)
uid = .Cells(Selection.row, 1)
End With
' build update command
sql = "UPDATE [" & sTable & "] SET [" & sField & "] = ? WHERE [" & pk & "] = ?"
Debug.Print sql, sValue, uid
' run update
Set cn = DbConnect("TestServer2019", "Work2023")
Set cmdUpd = New ADODB.Command
With cmdUpd
.ActiveConnection = cn
.CommandText = sql
.Parameters.Append .CreateParameter("P1", adVarChar, adParamInput, 255)
.Parameters.Append .CreateParameter("P2", adBigInt, adParamInput)
.Parameters(0).Value = sValue
.Parameters(1).Value = uid
.Execute
End With
cn.Close
Set cn = Nothing
MsgBox sql & " update executed"
End Sub