How to export spreadsheet data into SQLServer? - vba

Question

I am new to Vba, hope someone will solve my problem. I am trying to update data present in my spreadsheet. Actually i have 20,000 records, each record has around 74 columns. So updating them record by record by using ADO taking so much of time. Is there any alternative approach to update those records in single shot. Any help would be appreciated greatly.
Currently my code is.
Sub InitialExport()
On Error GoTo ErrHandler
Dim con As New ADODB.Connection
Dim Query As String
Dim EffectedRecs As Long
Dim i As Integer
ServerName = "192.178.78.36"
'Setting ConnectionString
con.ConnectionString = "Provider=SQLOLEDB; " & _
"Data Source=" & ServerName & "; " & _
"Initial Catalog=AppEmp;" & _
"User ID=sa; Password=admin08; "
'Setting provider Name
con.Provider = "Microsoft.JET.OLEDB.12.0"
'Opening connection
con.Open
With ThisWorkbook.Sheets("Export")
For i = 3 To ThisWorkbook.Sheets("Export").Range("B65536").End(xlUp).Row
'---------------------->
EmpId = .Range("B" & i).Value 'Emp Code-varchar
C = .Range("C" & i).Value 'Emp Name-varchar
D = .Range("D" & i).Value
E = .Range("E" & i).Value
F = .Range("F" & i).Value
G = .Range("G" & i).Value
H = .Range("H" & i).Value
II = .Range("I" & i).Value
JJ = .Range("J" & i).Value
k = .Range("K" & i).Value
l = .Range("L" & i).Value
M = .Range("M" & i).Value
N = CheckNull(.Range("N" & i).Value)
O = CheckNull(.Range("O" & i).Value)
P = CheckNull(.Range("P" & i).Value)
Q = CheckNull(.Range("Q" & i).Value)
R = CheckNull(.Range("R" & i).Value)
S = .Range("S" & i).Value
T = .Range("T" & i).Value
U = .Range("U" & i).Value
v = .Range("V" & i).Value
W = .Range("W" & i).Value
X = CheckNull(.Range("X" & i).Value)
Y = .Range("Y" & i).Value
Z = .Range("Z" & i).Value
AA = CheckNull(.Range("AA" & i).Value)
AB = .Range("AB" & i).Value
AC = CheckNull(.Range("AC" & i).Value)
AD = CheckNull(.Range("AD" & i).Value)
AE = CheckNull(.Range("AE" & i).Value)
AF = CheckNull(.Range("AF" & i).Value)
AG = .Range("AG" & i).Value
AH = CheckNull(.Range("AH" & i).Value)
AI = CheckNull(.Range("AI" & i).Value)
AJ = CheckNull(.Range("AJ" & i).Value)
AK = CheckNull(.Range("AK" & i).Value)
AL = CheckNull(.Range("AL" & i).Value)
AM = CheckNull(.Range("AM" & i).Value)
AN = CheckNull(.Range("AN" & i).Value)
AO = CheckNull(.Range("AO" & i).Value)
AP = CheckNull(.Range("AP" & i).Value)
AQ = CheckNull(.Range("AQ" & i).Value)
AR = CheckNull(.Range("AR" & i).Value)
aAS = CheckNull(.Range("AS" & i).Value)
AT = .Range("AT" & i).Value
AU = CheckNull(.Range("AU" & i).Value)
AV = CheckNull(.Range("AV" & i).Value)
AW = CheckNull(.Range("AW" & i).Value)
AX = CheckNull(.Range("AX" & i).Value)
AY = CheckNull(.Range("AY" & i).Value)
AZ = CheckNull(.Range("AZ" & i).Value)
BA = CheckNull(.Range("BA" & i).Value)
BB = CheckNull(.Range("BB" & i).Value)
BC = CheckNull(.Range("BC" & i).Value)
BD = CheckNull(.Range("BD" & i).Value)
BE = .Range("BE" & i).Value
BF = .Range("BF" & i).Value
BG = CheckNull(.Range("BG" & i).Value)
BH = .Range("BH" & i).Value
BI = .Range("BI" & i).Value
BJ = CheckNull(.Range("BJ" & i).Value)
BK = CheckNull(.Range("BK" & i).Value)
BL = CheckNull(.Range("BL" & i).Value)
BM = .Range("BM" & i).Value
BN = .Range("BN" & i).Value
Query = "Exec HRApp_P_AddEmpData '" & EmpId & "','" & C & "','" & D & "','" & E & "','" & F & "','" & G & "','" & H & "','" & II & "','" & JJ & "','" & k & "','" & l & "','" & M & "'," & N & "," & O & "," & P & "," & Q & "," & R & ",'" & S & "','" & T & "','" & U & "','" & v & "','" & W & "'," & X & ",'" & Y & "','" & Z & "'," & AA & ",'" & AB & "'," & AC & "," & AD & "," & AE & "," & AF & ",'" & AG & "'," & AH & "," & AI & "," & AJ & "," & AK & ",'" & AL & "'," & AM & "," & AN & "," & AO & "," & AP & "," & AQ & "," & AR & "," & aAS & ",'" & AT & "'," & AU & "," & AV & "," & AW & "," & AX & "," & AY & "," & AZ & "," & BA & "," & BB & "," & BC & "," & BD & ",'" & BE & "','" & BF & "'," & BG & ",'" & BH & "','" & BI & "'," & BJ & "," & BK & "," & BL & ",'" & BM & "','" & BN & "'"
con.Execute Query
Next
End With
con.Close
Set con = Nothing
Exit Sub
ErrHandler: 'MsgBox "The Not able ta Save Data"
Set con = Nothing
End Sub
The above code is working fine. But it is taking more time to update data.:-(
Now my code became like this
Private Sub Worksheet_Activate()
Dim adoConn As New ADODB.Connection
Dim adoRS As New ADODB.Recordset
Dim sQuery As String
Dim EffectedRecs As Long
Dim sFields As String
Dim sValues As String
Dim iRow As Integer
Dim iField As Integer
ServerName = "193.128.125.14"
con_Str = "Provider=SQLOLEDB; " & _
"Data Source=" & ServerName & "; " & _
"Initial Catalog=DB_At&T;" & _
"User ID=sa; Password=ad28; "
sQuery = "select * from Currency where 1=2"
sValues = ""
With adoConn
.ConnectionString = con_Str
.Provider = "Microsoft.JET.OLEDB.12.0"
.CursorLocation = adUseClient
.Open
End With
With adoRS
.ActiveConnection = adoConn
.CursorLocation = adUseClient
.LockType = adLockBatchOptimistic
.CursorType = adOpenKeyset ' adOpenDynamic
.Source = sQuery
.Open
End With
With ThisWorkbook.Sheets("Export")
For iRow = 3 To ThisWorkbook.Sheets("Export").Range("B65536").End(xlUp).Row
For iField = 0 To adoRS.Fields.Count - 1
sFields = sFields & "," & adoRS.Fields(iField).Name
Next
sValues = sValues & "," & .Range("A" & iRow).Value
sValues = sValues & "," & .Range("B" & iRow).Value
sValues = sValues & "," & .Range("C" & iRow).Value
sValues = sValues & "," & .Range("D" & iRow).Value
sFields = Right(sFields, Len(sFields) - 1) 'Removing ,
sValues = Right(sValues, Len(sValues) - 1) 'Removing ,
adoRS.AddNew FieldList = sFields, Values:=sValues
Next
End With
adoRS.UpdateBatch adAffectAllChapters
adoRS.Close
adoConn.Close
End Sub

Answer 1

you could try this:
Sub InitialExport()
On Error GoTo ErrHandler
'
Dim adoConn As New ADODB.Connection
Dim adoRS As ADODB.Recordset
'
Dim sQuery As String
Dim EffectedRecs As Long
Dim sFields As String
Dim sValues As String
'
Dim iRow As Integer
Dim iField As Integer
'
ServerName = SERVER_NAME
'
sQuery="SELECT * from tableName where 1 =2" ' get an empty recordset!
'
'Set the connection and open
with adoConn
.ConnectionString = CONNECTION_STRING
.Provider = "Microsoft.JET.OLEDB.12.0"
.cursorlocation=aduseclient
.Open
end with
'
' set the Recordset and open
With adoRS
.activeconnection=adoconn
.CursorLocation = adUseClient
.LockType = adLockBatchOptimistic
.CursorType = adopenkeyset ' adOpenDynamic
.Source = sQuery
.Open
End With
'
' now get the data into the recordset
With ThisWorkbook.Sheets("Export")
For iRow = 3 To ThisWorkbook.Sheets("Export").Range("B65536").End(xlUp).Row
' here loop through all the columns
For iField = 0 To adoRS.Fields.Count - 1
' adding the column names to the Variable sFields
sFields = sFields & "," & adoRS.Fields(iField).Name
'
' adding the values from the worksheet for this row
sValues = sValues & ", " & .Cells(iRow, iField).Text
Next
'
' add a new record with the fields and values
adoRS.AddNew FieldList:=sFields, Values:=sValues
'
Next
'
' update all the rows in one step
adoRS.UpdateBatch adAffectAllChapters ' update them all in one step!
'
End Sub
just change tablename in the query to the correct table and make sure the columns in the worksheet are in the same order and datatype as the columns in the table
for ADO Recordset help see:
MSDN Library - ADO Recordset, AddNew method
and
MSDN Library - ADO Recordset, UpdateBatch
and
W3Schools
I hope that get's you started!
Philip

Answer 2

Another option could be uploading your entire Excel Sheet as a csv file directly into the server using BulkInsert.
The Sql code might look as simple as this:
BULK INSERT [DB].[dbo].[Importa_Aux] FROM '\\share\filename.csv' WITH ( FIELDTERMINATOR = ',' , ROWTERMINATOR = '\n' , FIRSTROW = 2 )
Then simply work your data updates in SqlServer.