Maitain SQL Database from Excel

[wikus]

I am using the following code to retrieve all SQL tables in a database when workbook is opened and update tables automatically when a change is made on a sheet. The retrieve part works fine but it doesn't update the changes to the sql tables. Can somebody please help?

Public con As ADODB.Connection
Public bIgnoreChange As Boolean
Dim pk As New Collection
Dim oldValue As Variant
Dim nRecordCount As Integer
Private Sub Workbook_Deactivate()
If Not (con Is Nothing) Then
con.Close
Set con = Nothing
End If
End Sub
Function IsInPrimaryKey(name As String)
For Each pki In pk
If (pki = name) Then
IsInPrimaryKey = True
Exit Function
End If
Next pki
IsInPrimaryKey = False
End Function
Function MakeSQLText(data As Variant)
If (IsNumeric(data)) Then
MakeSQLText = data
Else
MakeSQLText = "'" & Replace(data, "'", "''") & "'"
End If
End Function
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
bIgnoreChange = True
Set con = New ADODB.Connection
con.Provider = "sqloledb"
sConnectionString = "Server=SERVERNAME;Database=DBNAME;UID=sa;Pwd=password"
con.Open sConnectionString

While (pk.Count > 0)
pk.Remove 1
Wend

On Error GoTo NoCon
Set rs = con.Execute("SELECT COLUMN_NAME FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS AS tc INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS kcu ON tc.CONSTRAINT_NAME = kcu.CONSTRAINT_NAME WHERE tc.CONSTRAINT_TYPE = 'PRIMARY KEY' AND tc.TABLE_NAME = '" & Sh.name & "'")

While (Not rs.EOF)
pk.Add CStr(rs(0))
rs.MoveNext
Wend

Sh.UsedRange.Clear

Set rs = con.Execute("SELECT * FROM " & Sh.name)

Dim TheCells As Range
Set TheCells = Sh.Range("A1")
For i = 0 To rs.Fields.Count - 1
TheCells.Offset(0, i).Value = rs.Fields(i).name
Next i

nRow = 1
While (Not rs.EOF)
For i = 0 To rs.Fields.Count - 1
TheCells.Offset(nRow, i).Value = rs(i)
Next
rs.MoveNext
nRow = nRow + 1
Wend
nRecordCount = nRow - 1

bIgnoreChange = (pk.Count = 0) And (nRecordCount > 0)
Exit Sub
NoCon:
con.Close
Set con = Nothing
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If bIgnoreChange Or con Is Nothing Then
Exit Sub
End If

If (Target.Value = oldValue) Then
oldValue = Application.ActiveCell.Value
Exit Sub
End If

If Target.Row < 2 Or Sh.Cells(1, Target.Row).Text = "" Or Sh.Cells(1, Target.Column) = "" Or (Target.Row > nRecordCount + 1) Then
Target.Value = oldValue
oldValue = Application.ActiveCell.Value
MsgBox "You can only edit items inside the table"
Exit Sub
End If

If (IsInPrimaryKey(Sh.Cells(1, Target.Column).Text)) Then
Target.Value = oldValue
oldValue = Application.ActiveCell.Value
MsgBox "This column is a part of the primary key, so it cannot be changed"
Exit Sub
End If

Dim Names As Range
Set Names = Sh.Range("A1")
nColumn = 0
sWhere = ""
While (Names.Offset(0, nColumn).Text <> "")
If (IsInPrimaryKey(Names.Offset(0, nColumn).Text)) Then
If (sWhere <> "") Then
sWhere = sWhere & " AND "
End If
sWhere = sWhere & Sh.Cells(1, nColumn + 1).Text & " = " & MakeSQLText(Sh.Cells(Target.Row, nColumn + 1))
End If
nColumn = nColumn + 1
Wend

sSQL = "UPDATE " & Sh.name & " SET " & Sh.Cells(1, Target.Column).Text & " = " & MakeSQLText(Target.Text) & " WHERE " & sWhere
con.Execute sSQL
oldValue = Application.ActiveCell.Value

End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If (Not bIgnoreChange) Then
oldValue = Application.ActiveCell.Value
End If
End Sub

 

[hayath786]

Try the below code:

' General variables we'll need
Public con As ADODB.Connection
Public bIgnoreChange As Boolean
Dim pk As New Collection
Dim oldValue As Variant
Dim nRecordCount As Integer


Private Sub Workbook_Deactivate()
If Not (con Is Nothing) Then
con.Close
Set con = Nothing
End If
End Sub


Function IsInPrimaryKey(name As String)
For Each pki In pk
If (pki = name) Then
IsInPrimaryKey = True
Exit Function
End If
Next pki
IsInPrimaryKey = False
End Function


Function MakeSQLText(data As Variant)
If (IsNumeric(data)) Then
MakeSQLText = data
Else
MakeSQLText = "'" & Replace(data, "'", "''") & "'"
End If
End Function


Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' Let's retrieve the data from the SQL Server table with the same name as the sheet
bIgnoreChange = True
Set con = New ADODB.Connection
con.Provider = "sqloledb"
sConnectionString = "Server=SERVERNAME;Database=DBNAME;UID=sa;Pwd=password"
con.Open sConnectionString

' Clean up old Primary Key
While (pk.Count > 0)
pk.Remove 1
Wend

' Try to retrieve the primary key information
On Error GoTo NoCon
Set rs = con.Execute("SELECT COLUMN_NAME FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS AS tc INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS kcu ON tc.CONSTRAINT_NAME = kcu.CONSTRAINT_NAME WHERE tc.CONSTRAINT_TYPE = 'PRIMARY KEY' AND tc.TABLE_NAME = '" & Sh.name & "'")

' Fill up the primary key infomration
While (Not rs.EOF)
pk.Add CStr(rs(0))
rs.MoveNext
Wend

' Clean up the sheet's contents
Sh.UsedRange.Clear

' Now get the table's data
Set rs = con.Execute("SELECT * FROM " & Sh.name)

' Set the name of the fields
Dim TheCells As Range
Set TheCells = Sh.Range("A1")
For i = 0 To rs.Fields.Count - 1
TheCells.Offset(0, i).Value = rs.Fields(i).name
Next i

' Get value for each field
nRow = 1
While (Not rs.EOF)
For i = 0 To rs.Fields.Count - 1
TheCells.Offset(nRow, i).Value = rs(i)
Next
rs.MoveNext
nRow = nRow + 1
Wend
nRecordCount = nRow - 1

bIgnoreChange = (pk.Count = 0) And (nRecordCount > 0)


Exit Sub


NoCon:
con.Close
Set con = Nothing
End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' No loops, and don't do nothing if there's no connection
If bIgnoreChange Or con Is Nothing Then
Exit Sub
End If

' Is something different?
If (Target.Value = oldValue) Then
' No change
oldValue = Application.ActiveCell.Value
Exit Sub
End If

' Don't allow changes in the column names or outside of the table borders
If Target.Row < 2 Or Sh.Cells(1, Target.Row).Text = "" Or Sh.Cells(1, Target.Column) = "" Or (Target.Row > nRecordCount + 1) Then
Target.Value = oldValue
oldValue = Application.ActiveCell.Value
MsgBox "You can only edit items inside the table"
Exit Sub
End If

' Is this change is in a primary key column - if so, we can't edit it
If (IsInPrimaryKey(Sh.Cells(1, Target.Column).Text)) Then
Target.Value = oldValue
oldValue = Application.ActiveCell.Value
MsgBox "This column is a part of the primary key, so it cannot be changed"
Exit Sub
End If

' Build the primary key from the data in this row
Dim Names As Range
Set Names = Sh.Range("A1")
nColumn = 0
sWhere = ""
While (Names.Offset(0, nColumn).Text <> "")
If (IsInPrimaryKey(Names.Offset(0, nColumn).Text)) Then
If (sWhere <> "") Then
sWhere = sWhere & " AND "
End If
sWhere = sWhere & Sh.Cells(1, nColumn + 1).Text & " = " & MakeSQLText(Sh.Cells(Target.Row, nColumn + 1))
End If
nColumn = nColumn + 1
Wend

' Update the server!
sSQL = "UPDATE " & Sh.name & " SET " & Sh.Cells(1, Target.Column).Text & " = " & MakeSQLText(Target.Text) & " WHERE " & sWhere
con.Execute sSQL
oldValue = Application.ActiveCell.Value

End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If (Not bIgnoreChange) Then
' Remember the old value
oldValue = Application.ActiveCell.Value
End If
End Sub

 

[wikus]

Thanks for your reply, I appreciate your help.