This is my VBA script in Sheet1 which contain Export and Import
Option Explicit
Private Sub cmdExport_Click()
On Error GoTo ErrExit
Dim cn_ADO As ADODB.Connection
Dim rs_ADO As ADODB.Recordset
Dim cmd_ADO As ADODB.Command
Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DbConn As String
Dim SQLQuery As String
Dim strStatus As String
Dim i As Integer
Dim j As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
Dim iStep As Integer
Dim strCurrentValue As String
Dim strLastValue As String
Dim lColorIndex As Integer
iStep = 100
jOffset = 4
iStartRow = 8
i = iStartRow
SQLUser = "sa"
SQLPassword = "12345"
SQLServer = "DESKTOP-5877NMS\SQLEXPRESS"
DBName = "kpi"
DbConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
"Data Source=" & SQLServer & ";Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;" & _
"Use Encryption for Data=False;Tag with column collation when possible=False"
Set cn_ADO = New ADODB.Connection
cn_ADO.Open DbConn
SQLQuery = "select "
SQLQuery = SQLQuery + "[ID], "
SQLQuery = SQLQuery + "[F2], "
SQLQuery = SQLQuery + "[2019], "
SQLQuery = SQLQuery + "[2020], "
SQLQuery = SQLQuery + "[Jan], "
SQLQuery = SQLQuery + "[Feb], "
SQLQuery = SQLQuery + "[Mar], "
SQLQuery = SQLQuery + "[Apr], "
SQLQuery = SQLQuery + "[May], "
SQLQuery = SQLQuery + "[Jun], "
SQLQuery = SQLQuery + "[Jul], "
SQLQuery = SQLQuery + "[Aug], "
SQLQuery = SQLQuery + "[Sep], "
SQLQuery = SQLQuery + "[Oct], "
SQLQuery = SQLQuery + "[Nov], "
SQLQuery = SQLQuery + "[Dec], "
SQLQuery = SQLQuery + "[2021], "
SQLQuery = SQLQuery + "[Tgt], "
SQLQuery = SQLQuery + "[UOM] "
SQLQuery = SQLQuery + "from "
SQLQuery = SQLQuery + "dbo.RAWDATA1 "
Application.Cursor = xlWait
Application.StatusBar = "Logging onto database..."
Set cmd_ADO = New ADODB.Command
cmd_ADO.CommandText = SQLQuery
cmd_ADO.ActiveConnection = cn_ADO
cmd_ADO.Execute
' Open the recordset.
Set rs_ADO = New ADODB.Recordset
Set rs_ADO.ActiveConnection = cn_ADO
rs_ADO.Open cmd_ADO
Range(Cells(i, 1), Cells(Rows.Count, jOffset + rs_ADO.Fields.Count)).Clear
Cells(1, 1).Select
Application.StatusBar = "Formatting columns..."
'Output Columns names
For j = 0 To rs_ADO.Fields.Count - 1
Cells(i, j + jOffset).Value = rs_ADO.Fields(CLng(j)).Name
Cells(i, j + jOffset).Font.Bold = True
Cells(i, j + jOffset).Select
With Selection.Interior
If rs_ADO.Fields(CLng(j)).Name = "2019" Or _
rs_ADO.Fields(CLng(j)).Name = "2020" Or _
rs_ADO.Fields(CLng(j)).Name = "Jan" Or _
rs_ADO.Fields(CLng(j)).Name = "Feb" Or _
rs_ADO.Fields(CLng(j)).Name = "Mar" Or _
rs_ADO.Fields(CLng(j)).Name = "Apr" Or _
rs_ADO.Fields(CLng(j)).Name = "May" Or _
rs_ADO.Fields(CLng(j)).Name = "Jun" Or _
rs_ADO.Fields(CLng(j)).Name = "Jul" Or _
rs_ADO.Fields(CLng(j)).Name = "Aug" Or _
rs_ADO.Fields(CLng(j)).Name = "Sep" Or _
rs_ADO.Fields(CLng(j)).Name = "Oct" Or _
rs_ADO.Fields(CLng(j)).Name = "Nov" Or _
rs_ADO.Fields(CLng(j)).Name = "Dec" Or _
rs_ADO.Fields(CLng(j)).Name = "2021" Then
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
Else
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End If
End With
Next j
DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
Application.ScreenUpdating = False
strStatus = "Loading data..."
Application.StatusBar = strStatus
lColorIndex = xlNone
'dataset output
While Not rs_ADO.EOF
i = i + 1
strCurrentValue = rs_ADO.Fields(0).Value
If strCurrentValue = strLastValue Then
lColorIndex = lColorIndex
Else
lColorIndex = IIf(lColorIndex = xlNone, 15, xlNone)
End If
For j = 0 To rs_ADO.Fields.Count - 1
Cells(i, j + jOffset).Interior.ColorIndex = lColorIndex
If lColorIndex <> xlNone Then
Cells(i, j + jOffset).Interior.Pattern = xlSolid
End If
Cells(i, j + jOffset).Value = rs_ADO.Fields(j).Value
Next j
rs_ADO.MoveNext
If i - iStartRow < iStep Then
Application.StatusBar = strStatus & " record count: " & i - iStartRow
Else
'a Mod b ==>> a - (b * (a \ b))
If (i - iStartRow) - (iStep * ((i - iStartRow) \ iStep)) = 0 Then
Application.StatusBar = strStatus & " record count: " & i - iStartRow
DoEvents
End If
End If
Wend
'Close ADO and recordset
rs_ADO.Close
Set cn_ADO = Nothing
Set cmd_ADO = Nothing
Set rs_ADO = Nothing
Application.StatusBar = "Total record count: " & i - iStartRow
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Exit Sub
ErrExit:
MsgBox "Error: " & Err & " " & Error(Err)
Application.StatusBar = False
Application.Cursor = xlDefault
If Not cn_ADO Is Nothing Then
Set cn_ADO = Nothing
End If
If Not cmd_ADO Is Nothing Then
Set cmd_ADO = Nothing
End If
If Not rs_ADO Is Nothing Then
Set rs_ADO = Nothing
End If
End Sub
Private Sub cmdImport_Click()
On Error GoTo ErrExit
Dim cn_ADO As ADODB.Connection
Dim cmd_ADO As ADODB.Command
Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DbConn As String
Dim SQLQuery As String
Dim strWhere As String
'Dim strStatus As String
Dim i As Integer
'Dim j As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
'Dim iStep As Integer
'Data Columns
Dim strID As String
Dim strF2 As String
Dim str2019 As String
Dim str2020 As String
Dim strJan As String
Dim strFeb As String
Dim strMar As String
Dim strApr As String
Dim strMay As String
Dim strJun As String
Dim strJul As String
Dim strAug As String
Dim strSep As String
Dim strOct As String
Dim strNov As String
Dim strDec As String
Dim str2021 As String
Dim strTgt As String
Dim strUOM As String
'iStep = 100
jOffset = 4
iStartRow = 9
i = iStartRow
SQLUser = "sa"
SQLPassword = "12345"
SQLServer = "DESKTOP-5877NMS\SQLEXPRESS"
DBName = "kpi"
DbConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
"Data Source=" & SQLServer & ";Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;" & _
"Use Encryption for Data=False;Tag with column collation when possible=False"
Set cn_ADO = New ADODB.Connection
cn_ADO.Open DbConn
Set cmd_ADO = New ADODB.Command
While Cells(i, jOffset).Value <> ""
strID = Cells(i, 0 + jOffset).Value
strF2 = Cells(i, 1 + jOffset).Value
str2019 = Cells(i, 2 + jOffset).Value
str2020 = Cells(i, 3 + jOffset).Value
strJan = Cells(i, 4 + jOffset).Value
strFeb = Cells(i, 5 + jOffset).Value
strMar = Cells(i, 6 + jOffset).Value
strApr = Cells(i, 7 + jOffset).Value
strMay = Cells(i, 8 + jOffset).Value
strJun = Cells(i, 9 + jOffset).Value
strJul = Cells(i, 10 + jOffset).Value
strAug = Cells(i, 11 + jOffset).Value
strSep = Cells(i, 12 + jOffset).Value
strOct = Cells(i, 13 + jOffset).Value
strNov = Cells(i, 14 + jOffset).Value
strDec = Cells(i, 15 + jOffset).Value
str2021 = Cells(i, 16 + jOffset).Value
strTgt = Cells(i, 17 + jOffset).Value
strUOM = Cells(i, 18 + jOffset).Value
strWhere = "ID = " & strID
SQLQuery = "update dbo.RAWDATA1 " & _
"set " & _
"[2019] = '" & str2019 & "', " & _
"[2020] = '" & str2020 & "', " & _
"Jan = '" & strJan & "', " & _
"Feb = '" & strFeb & "', " & _
"Mar = '" & strMar & "', " & _
"Apr = '" & strApr & "', " & _
"May = '" & strMay & "', " & _
"Jun = '" & strJun & "', " & _
"Jul = '" & strJul & "', " & _
"Aug = '" & strAug & "', " & _
"Sep = '" & strSep & "', " & _
"Oct = '" & strOct & "', " & _
"Nov = '" & strNov & "', " & _
"Dec = '" & strDec & "', " & _
"[2021] = '" & str2021 & "' " & _
"where " & strWhere
cmd_ADO.CommandText = SQLQuery
cmd_ADO.ActiveConnection = cn_ADO
cmd_ADO.Execute
i = i + 1
Wend
Set cmd_ADO = Nothing
Set cn_ADO = Nothing
Exit Sub
ErrExit:
MsgBox "Error: " & Err & " " & Error(Err)
Application.StatusBar = False
Application.Cursor = xlDefault
If Not cn_ADO Is Nothing Then
Set cn_ADO = Nothing
End If
If Not cmd_ADO Is Nothing Then
Set cmd_ADO = Nothing
End If
End Sub
This is my
SQL Table
Excel Data
Export SQL to Excel works perfectly but for Import Excel to SQL when I press Import button it show error
-2147217913 error converting data type varchar to numeric
I'm new with VBA and SQL.
Change the end of the SQL to
"[2021] = " & IIF(Len(str2021) = O, "Null",str2021) & _ ' no single quotes
" where " & strWhere ' note added leading space
Thank you guys for helping me . I've tried change the SQL as stated in the comments and answer given by CDP1802 . It works perfectly . But I try to change all value to nvarchar(max) except for Id and it works perfectly without any error.
Related
I need to update a set of values from an Excel Worksheet into a SQL Server Table.
This is the Excel Table:
I wrote some code in VBA to do this, but I'm not very expert.
The update work just fine except for the part where it truncate decimals.
As you can see the decimals get cuts off. The fields on SQL are declared as Decimal (19,5).
Sure there's something wrong in the VBA code. Here's my code.
On Error GoTo RigaErrore
Dim cn_ADO As Object
Dim cmd_ADO As Object
Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DBConn As String
Dim SQLQuery As String
Dim strWhere As String
Dim i As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'iStep = 100
jOffset = 20
iStartRow = 3
i = iStartRow
SQLUser = "xxxx"
SQLPassword = "xxx"
SQLServer = "xxxxxxxx"
DBName = "xxxxx"
DBConn = "Provider=SQLOLEDB.1;Pesist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
"Data Source=" & SQLServer & ";DataTypeCompatibility=80;"
Set cn_ADO = CreateObject("ADODB.Connection")
cn_ADO.Open DBConn
Set cmd_ADO = CreateObject("ADODB.Command")
While Cells(i, jOffset).Value <> ""
xlsIDKey = Cells(i, 0 + jOffset)
xlsVendSim = CDbl(Cells(i, 1 + jOffset))
xlsOreSim = CDbl(Cells(i, 2 + jOffset))
xlsProdVar = CDbl(Cells(i, 3 + jOffset))
xlsOreSimVar = CDbl(Cells(i, 4 + jOffset))
strWhere = "ID_KEY = '" & xlsIDKey & "'"
SQLQuery = "UPDATE DatiSimulati " & _
"SET " & _
"VEND_SIM = Cast(('" & xlsVendSim & "') as decimal (19,5)), " & _
"ORE_SIM = Cast(('" & xlsOreSim & "') as decimal (19,5)), " & _
"PROD_VAR = Cast(('" & xlsProdVar & "') as decimal (19,5)), " & _
"ORE_SIM_VAR = Cast(('" & xlsOreSimVar & "') as decimal (19,5)) " & _
"WHERE " & strWhere
cmd_ADO.CommandText = SQLQuery
cmd_ADO.ActiveConnection = cn_ADO
cmd_ADO.Execute
i = i + 1
Wend
Set cmd_ADO = Nothing
Set cn_ADO = Nothing
Exit Sub
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Application.StatusBar = False
Application.Cursor = xlDefault
If Not cn_ADO Is Nothing Then
Set cn_ADO = Nothing
End If
If Not cmd_ADO Is Nothing Then
Set cmd_ADO = Nothing
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thanks everybody who could help solve this.
A work-around would be to replace the decimal commas with dots.
Option Explicit
Sub connectDB()
Const SQLUser = "#"
Const SQLPassword = "#"
Const SQLServer = "#"
Const DBName = "#"
Dim DBConn As String
DBConn = "Provider=SQLOLEDB.1;Pesist Security Info=True" & _
";User ID=" & SQLUser & ";Password=" & SQLPassword & _
";Initial Catalog=" & DBName & _
";Data Source=" & SQLServer & _
";DataTypeCompatibility=80;"
Dim cn_ADO As Object, cmd_ADO As Object
Set cn_ADO = CreateObject("ADODB.Connection")
cn_ADO.Open DBConn
Set cmd_ADO = CreateObject("ADODB.Command")
cmd_ADO.ActiveConnection = cn_ADO
Const joffset = 20
Const iStartRow = 3
Dim SQLQuery As String, sIDKey As String
Dim sVendSim As String, sOreSim As String
Dim sProdVar As String, sOreSimVar As String
Dim i As Long
i = iStartRow
' create log file
Dim LOGFILE As String
LOGFILE = ThisWorkbook.Path & "\logfile.txt"
Dim fs As Object, ts As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.CreateTextFile(LOGFILE, True)
While Len(Cells(i, joffset).Value) > 0
sIDKey = Cells(i, 0 + joffset)
sVendSim = Replace(Cells(i, 1 + joffset), ",", ".")
sOreSim = Replace(Cells(i, 2 + joffset), ",", ".")
sProdVar = Replace(Cells(i, 3 + joffset), ",", ".")
sOreSimVar = Replace(Cells(i, 4 + joffset), ",", ".")
SQLQuery = "UPDATE DatiSimulati " & _
"SET " & _
"VEND_SIM = " & sVendSim & ", " & _
"ORE_SIM = " & sOreSim & ", " & _
"PROD_VAR = " & sProdVar & ", " & _
"ORE_SIM_VAR = " & sOreSimVar & " " & _
"WHERE ID_KEY = " & sIDKey
ts.writeline SQLQuery & vbCr
cmd_ADO.CommandText = SQLQuery
cmd_ADO.Execute
i = i + 1
Wend
ts.Close
MsgBox i - iStartRow & " records updated see " & LOGFILE, vbInformation
End Sub
I have an excel workbook that contains about 5,000 rows of data. I have two buttons mapped to macros. One button will delete all data in the table, and reinsert it from the Excel Workbook, and the other will only insert the 'new' rows based on a unique ID.
I am finding that both of these buttons are taking a long time to run. ~10-15 minutes. Right now, it is performing the insert for every row, but I am looking to combine this.
Basically, I would like to loop through ~100 or so rows then insert. Then loop through the next hundred rows and insert.
Any suggestions would be greatly appreciated. VBA / Coding in general is not my forte and i'm pulling a brick wall on this one.
Thanks!
Sub Rebuild_Click()
' ***********************
' ** Declare Variables **
' ***********************
Dim conn As New ADODB.Connection
Dim iRowNo As Integer
Dim sSTATUS, sCHANNEL, sISSUE, sLOB, sDESC, sIN, sJN, sIS, sPRIME, sIU, sTR, sAU As String
Dim answer, sQTY, sRRSC, sOA, sMeetings, sOutages As Integer
Dim sDATE As Date
With Sheets("OASYS ADMIN TRACKER")
' ****************************
' ** Show Information Popup **
' ****************************
answer = MsgBox("You are about to update the database with ~5,000 records." & vbCrLf & "" & vbCrLf & "This will take approximately 5 minutes." & vbCrLf & "" & vbCrLf & "If you wish to continue, please press Yes. Otherwise, Press No" & vbCrLf & "" & vbCrLf & "----------" & vbCrLf & "EXCEL IS NOT FROZEN." & vbCrLf & "" & vbCrLf & "****DO NOT CLOSE EXCEL ****", vbYesNo + vbQuestion, "Update Database")
' ***********************
' ** Open IF Statement **
' ***********************
If answer = vbYes Then
' ***********************
' ** Connection String **
' ***********************
conn.Open "Provider=SQLNCLI11;Password=XXXXX;User ID=XXXXX;Initial Catalog=SupportAdmin;Data Source=tcp:XXXXX;"
' *************************
' ** Purge Existing Data **
' *************************
conn.Execute "Delete FROM dbo.TestDB"
' *********************
' ** Skip Leader Row **
' *********************
iRowNo = 4
' ************************
' ** Begin Dataset Loop **
' ************************
Do Until .Cells(iRowNo, 3) = ""
sID = .Cells(iRowNo, 1)
sSTATUS = .Cells(iRowNo, 2)
sDATE = .Cells(iRowNo, 3)
sCHANNEL = .Cells(iRowNo, 4)
sISSUE = .Cells(iRowNo, 5)
sQTY = .Cells(iRowNo, 6)
sLOB = .Cells(iRowNo, 7)
sDESC = .Cells(iRowNo, 8)
sIN = .Cells(iRowNo, 9)
sJN = .Cells(iRowNo, 10)
sIS = .Cells(iRowNo, 11)
sPRIME = .Cells(iRowNo, 12)
sIU = .Cells(iRowNo, 13)
sTR = .Cells(iRowNo, 14)
sAU = .Cells(iRowNo, 15)
sRRSC = .Cells(iRowNo, 16)
sOA = .Cells(iRowNo, 17)
sOutages = .Cells(iRowNo, 18)
sMeetings = .Cells(iRowNo, 19)
' ***********************
' ** Replace ' in Data **
' ***********************
sDESC = Replace(sDESC, "'", "''")
sIS = Replace(sIS, "'", "''")
sIU = Replace(sIU, "'", "''")
' *****************
' ** Execute SQL **
' *****************
conn.Execute "insert into dbo.TestDB (ID,STATUS,DATE,CHANNEL,ISSUE,QTY,LOB,[DESC],[IN],JN,[IS],PRIME,IU,TR,AU,RRSC,OA,OUTAGES,MEETINGS) " & _
"values ('" & sID & "','" & sSTATUS & "', '" & sDATE & "','" & sCHANNEL & "', '" & sISSUE & "', '" & sQTY & "', '" & sLOB & "', '" & sDESC & "', '" & sIN & "', '" & sJN & "', '" & sIS & "', '" & sPRIME & "', '" & sIU & "', '" & sTR & "', '" & sAU & "', '" & sRRSC & "', '" & sOA & "', '" & sOutages & "', '" & sMeetings & "')"
iRowNo = iRowNo + 1
Loop
' ****************************
' ** Show Information Popup **
' ****************************
MsgBox "Database Update Complete!"
' *****************************
' ** Close Connection String **
' *****************************
conn.Close
Set conn = Nothing
' ****************************
' ** Close IF Statement **
' ****************************
Else
' do nothing
End If
End With
End Sub
Tried your code with makeshift table in local SQL Server 2005 and found taking only 10 seconds for around 5000 records. In your case the delay may be due to Database Size, network speed etc.
However after trying it with code to insert 100 records at a time the same time reduced to 1 odd second only.
Sub test2()
Dim conn As New ADODB.Connection
Dim LastRow As Long, LastCol As Long, iRowNo As Long, DataArr As Variant
Dim SqStr As String, ValStr As String, Rw As Long, Cl As Long
Dim Ws As Worksheet, tm As Double
tm = Timer
conn.Open "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;;Initial Catalog=test;Data Source=USER-PC\SQLEXPRESS"
conn.Execute "Delete FROM dbo.Test"
Set Ws = ThisWorkbook.Worksheets("Sheet1")
iRowNo = 4
LastRow = Ws.Range("C" & Rows.Count).End(xlUp).Row
DataArr = Ws.Range("A" & iRowNo & ":S" & LastRow)
LastCol = UBound(DataArr, 2)
SqStr = "insert into dbo.Test (ID,STATUS,DATE,CHANNEL,ISSUE,QTY,LOB,[DESC],[IN],JN,[IS],PRIME,IU,TR,AU,RRSC,OA,OUTAGES,MEETINGS) "
'Sqlstr=Sqlstr & " Values " 'May use for Sql Server 2008 and above
For Rw = 1 To UBound(DataArr, 1)
DataArr(Rw, 1) = Replace(DataArr(Rw, 1), "'", "''")
DataArr(Rw, 8) = Replace(DataArr(Rw, 8), "'", "''")
DataArr(Rw, 13) = Replace(DataArr(Rw, 13), "'", "''")
'ValStr = ValStr & "('" 'May use for Sql Server 2008 and above
ValStr = ValStr & "Select '"
For Cl = 1 To UBound(DataArr, 2)
'ValStr = ValStr & DataArr(Rw, Cl) & IIf(Cl < LastCol, "','", "')") 'May use for Sql Server 2008 and above
ValStr = ValStr & DataArr(Rw, Cl) & IIf(Cl < LastCol, "','", "'") ' Used for test in Sql Server 2005
Next Cl
If Rw Mod 100 = 0 Then ' exceute at 100 records
ValStr = SqStr & ValStr
conn.Execute ValStr
DoEvents
ValStr = ""
Debug.Print Rw, Timer - tm
Else
If Rw < UBound(DataArr, 1) Then
'ValStr = ValStr & ", " 'Modify Comma / Space between datasets of two rows according Sql version Syntax
ValStr = ValStr & " UNION ALL " 'Used for test with Sql Server 2005.
End If
End If
Next Rw
If Rw Mod 100 > 0 Then
ValStr = SqStr & ValStr
conn.Execute ValStr
DoEvents
ValStr = ""
Debug.Print Rw, Timer - tm
End If
Debug.Print "Total Seconds Taken: " & Timer - tm
End Sub
The INSERT SQl syntax along with connection string etc may please be modified for the type & version used by you along with suggestion in #Raymond Nijland's comment.
I need help with an massive loop through a continously expanding Access database consisting of approximately 280.000 rows of data. The procedure adds 3000 rows of data every week, and the macros running time is therefore only increasing. It takes around one hour to complete.
What is the optimal way to complete my procedure? I'm experienced with VBA, but SQL knowledge is limited.
The issue summarized is that the If-statement, located in "Help needed here" runs through 280.000 rows of data for 3000 companies.
The goal is that the fresh weekly scores of the company will be scored in JQHistory, but it has to take the date of running the macro into consideration
Note: Everything outside of "Help needed here", I've optimized in another macro. I've left it to hopefully improve the context of the issue.
Here is the non-optimized macro:
Sub OpdaterKvant()
Dim wb As Workbook
Dim ws As Worksheet
Dim DatoIn As Date
Set db = New ADODB.Connection
Set DbEQ = New ADODB.Connection
'The location of the database is determined outside the macro'
strConn = ConnectionString
db.Open strConn
Set wb = Workbooks.Open("My File Location")
Set ws = wb.Worksheets(1)
n = ws.UsedRange.Rows.Count
DateIn = Right(ws.Cells(1, 1), 2) & "-" & Mid(ws.Cells(1, 1), 5, 2) & "-" & Left(ws.Cells(1, 1), 4)
Dato = Format(DateIn, "mm-dd-yyyy")
db.Execute ("DELETE * FROM JQScores")
For i = 3 To n
Sedol = Replace(ws.Cells(i, 1), " ", "")
Company = Left(Replace(ws.Cells(i, 2), "'", ""), Len(Replace(ws.Cells(i, 2), "'", "")) - 1)
Country = Replace(ws.Cells(i, 3), " ", "")
Region = Replace(ws.Cells(i, 4), " ", "")
Sector = Replace(ws.Cells(i, 5), " ", "")
MarketCap = Replace(Replace(ws.Cells(i, 6), " ", ""), ",", ".")
JQRank = Replace(ws.Cells(i, 7), " ", "")
ValueRank = Replace(ws.Cells(i, 8), " ", "")
QualityRank = Replace(ws.Cells(i, 9), " ", "")
MomentumRank = Replace(ws.Cells(i, 10), " ", "")
JQScore = Replace(Replace(ws.Cells(i, 11), " ", ""), ",", ".")
'Inserts the information into the Access database.'
Sql = "Insert into JQScores (Sedol, Company, Region, Sector, MarketCapUSD, JQ_Rank, Value_Rank, Quality_Rank, Momentum_Rank, JQ_Score, Country) VALUES ('" & Sedol & "','" & Company & "', '" & Region & "', '" & Sector & "', " & MarketCap & ", '" & JQRank & "', '" & ValueRank & "', '" & QualityRank & "', '" & MomentumRank & "', " & JQScore & ", '" & Country & "')"
db.Execute (Sql)
'*** HELP NEEDED IN THIS SECTION'
If db.Execute("Select Count(Id) as NumId from JQHistory where Sedol='" & Sedol & "' and history_date=#" & Dato & "#")("NumId") = 0 Then
Sql = "Insert into JQHistory (History_date, Sedol, Selskabsnavn, JQScore, JQ_Rank, Value_Rank, Momentum_Rank, Quality_Rank, Marketcap) VALUES (#" & Dato & "#, '" & Sedol & "','" & Company & "'," & JQScore & ", '" & JQRank & "', '" & ValueRank & "', '" & MomentumRank & "', '" & QualityRank & "', " & MarketCap & ")"
db.Execute (Sql)
Else
Sql = "Update JQHistory set MarketCap=" & MarketCap & ", Selskabsnavn='" & Company & "' , JQ_Rank='" & JQRank & "', Value_Rank='" & ValueRank & "', Quality_Rank='" & QualityRank & "', Momentum_Rank='" & MomentumRank & "', JQScore=" & JQScore & " WHERE SEDOL='" & Sedol & "' and History_Date=#" & Dato & "#"
db.Execute (Sql)
End If
'***'
Next i
db.Close
wb.Close
The optimal way ended up using the DAO.Recordset and DAO.Database options, and a lot of tweaks for optimization.
The biggest shortcut was using the 'Recordset.FindFirst' to identify if the data should only be added (takes 22 seconds), or update the data with identical date (takes 12 minutes). Although mainly the scenario taking 22 seconds will happen.
The scenario taking 12 minutes is not optimized since it rarely happens.
Full solution:
Sub OpdaterKvant()
Dim wb As Workbook
Dim wbOp As Workbook
Dim ws As Worksheet
Dim wsOp As Worksheet
Dim i, n As Integer
Dim db As DAO.Database
Dim rsScores As DAO.Recordset
Dim rsHistory As DAO.Recordset
StartTime = Timer
Call PERFORMANCEBOOST(False)
Set PB = CREATEPROGRESSBAR
With PB
.SetStepCount (4)
.Show
End With
Set wbOp = ThisWorkbook
Set wsOp = wbOp.ActiveSheet
'Step 1: Open JQGCLE
Set wb = Workbooks.Open("Location", ReadOnly:=True)
Set ws = wb.Worksheets(1)
ws.Activate
n = ws.UsedRange.Rows.Count
DateIn = Right(ws.Cells(1, 1), 2) & "-" & Mid(ws.Cells(1, 1), 5, 2) & "-" & Left(ws.Cells(1, 1), 4)
'Step 2: Optag værdier i Excel
PB.Update "Data hentes fra JQGLCE-ark"
ReDim Sedol(3 To n) As String
ReDim Company(3 To n) As String
ReDim Country(3 To n) As String
ReDim Region(3 To n) As String
ReDim Sector(3 To n) As String
ReDim MarketCap(3 To n) As String 'Tal
ReDim MarketCapSQL(3 To n) As String 'Tal
ReDim JQRank(3 To n) As String
ReDim ValueRank(3 To n) As String
ReDim QualityRank(3 To n) As String
ReDim MomentumRank(3 To n) As String
ReDim JQScore(3 To n) As String 'Tal
ReDim JQScoreSQL(3 To n) As String 'Tal
For i = 3 To n
Sedol(i) = Trim(ws.Cells(i, 1))
Company(i) = Left(Replace(ws.Cells(i, 2), "'", ""), Len(Replace(ws.Cells(i, 2), "'", "")) - 0) 'Stod tidligere på minus 1 - Hvorfor?
Country(i) = Trim(ws.Cells(i, 3))
Region(i) = Trim(ws.Cells(i, 4))
Sector(i) = Trim(ws.Cells(i, 5))
MarketCap(i) = ws.Cells(i, 6) 'Til DAO
MarketCapSQL(i) = Replace(ws.Cells(i, 6), ",", ".") 'Til SQL
JQRank(i) = Trim(ws.Cells(i, 7))
ValueRank(i) = Trim(ws.Cells(i, 8))
QualityRank(i) = Trim(ws.Cells(i, 9))
MomentumRank(i) = Trim(ws.Cells(i, 10))
JQScore(i) = ws.Cells(i, 11) 'Til DAO
JQScoreSQL(i) = Replace(ws.Cells(i, 11), ",", ".") 'Til SQL
'DAO og SQL bliver behandlet forskelligt ift. komma
Next i
'Step 3: Indsæt værdier i Access-database
Set acc = New Access.Application
Set db = acc.DBEngine.OpenDatabase("Location", 1, 0)
'Step 3.1: JQScores
PB.Update "JQScores indsættes i databasen"
Set rsScores = db.OpenRecordset(Name:="JQScores", Type:=RecordsetTypeEnum.dbOpenDynaset)
db.Execute "DELETE * FROM JQScores"
For i = 3 To n
With rsScores
.AddNew
!Sedol = Sedol(i)
!Company = Company(i)
!Region = Region(i)
!Sector = Sector(i)
!MarketCapUSD = MarketCap(i)
!JQ_Rank = JQRank(i)
!Value_Rank = ValueRank(i)
!Quality_Rank = QualityRank(i)
!Momentum_Rank = MomentumRank(i)
!JQ_Score = JQScore(i)
!Country = Country(i)
.Update
End With
Next i
rsScores.Close
Set rsScores = Nothing
'Step 3.2: JQHistory
Set rsHistory = db.OpenRecordset(Name:="JQHistory", Type:=RecordsetTypeEnum.dbOpenDynaset)
With rsHistory
If .RecordCount <> 0 Then
i = 3
.FindFirst "History_Date = '" & DateIn & "'"
If .NoMatch = True Then
'Hvis datoen ikke er i datasættet, bliver dataen tilføjet
PB.Update "Hurtig: JQHistory indsættes i databasen"
For i = 3 To n
.AddNew
!History_Date = DateIn
!Sedol = Sedol(i)
!Selskabsnavn = Company(i)
!MarketCap = MarketCap(i)
!JQ_Rank = JQRank(i)
!Value_Rank = ValueRank(i)
!Quality_Rank = QualityRank(i)
!Momentum_Rank = MomentumRank(i)
!JQScore = JQScore(i)
.Update
Next i
Else
'Hvis datoen allerede er der, skal den opdateres
PB.Update "Langsom: JQHistory indsættes i databasen"
For i = 3 To n
db.Execute ("UPDATE JQHistory SET MarketCap=" & MarketCapSQL(i) & ", Selskabsnavn='" & Company(i) & "', JQ_Rank='" & JQRank(i) & "', Value_Rank='" & ValueRank(i) & "', Quality_Rank='" & QualityRank(i) & "', Momentum_Rank='" & MomentumRank(i) & "', JQScore=" & JQScoreSQL(i) & " WHERE SEDOL='" & Sedol(i) & "' and History_Date='" & DateIn & "'")
Next i
End If
End If
End With
rsHistory.Close
Set rsHistory = Nothing
'Step 4: Færdiggørelse
acc.DoCmd.Quit acQuitSaveAll 'Lukker og gemmer database
Set db = Nothing
wsOp.Activate
wsOp.Range("B7").Value = "Seneste data benyttet: " & DateIn
wb.Close SaveChanges:=False
Call PERFORMANCEBOOST(True)
Unload PB
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Opdatering fuldført. Proceduren tog " & MinutesElapsed & "."
End Sub
I am trying to pull the data with SQL query in excel. Query working fine and giving exact result but issue is I am passing the date variable 01-02-2005 in query and getting output -2006 (Last Column). I tried many possible ways as of my knowledge , it's doesn't work . please suggest how to get the custom date 01-02-2005 .
refer code
Sub CreateGLTable()
Const adOpenKeyset = 1
Const adLockOptimistic = 3
Const WORKSHEETNAME As String = "Sheet1"
Const TABLENAME As String = "Table1"
Dim conn As Object, rs As Object
Dim tbl As ListObject
Dim Destination As Range
Set Destination = ThisWorkbook.Worksheets("GL_OUTPUT").Range("a1")
Set conversiongl = ThisWorkbook.Worksheets("GL_OUTPUT")
ThisWorkbook.Worksheets("GL_MEMO").Range("E1").NumberFormat = "#"
Set rg = ThisWorkbook.Worksheets("GL_MEMO").UsedRange
Set tbl = ThisWorkbook.Worksheets("GL_MEMO").ListObjects.Add(xlSrcRange, rg, , xlYes)
With tbl.Sort
.SortFields.Clear
.SortFields.Add _
Key:=.Parent.ListColumns("NATURAL_ACCOUNT").DataBodyRange, SortOn:=xlSortOnValues, Order:= _
xlDescending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Set tbl = Worksheets(WORKSHEETNAME).ListObjects(TABLENAME)
Set conn = CreateObject("ADODB.Connection")
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
conn.Open
' On Error GoTo CloseConnection
Set rs = CreateObject("ADODB.Recordset")
With rs
.ActiveConnection = conn
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = getGLSQL(tbl)
.Open
With Destination
'tbl.HeaderRowRange.Copy .Range("c1")
.Range("a1").CopyFromRecordset rs
.Parent.ListObjects.Add SourceType:=xlSrcRange, Source:=.Range("a1").CurrentRegion, XlListObjectHasHeaders:=xlYes, TableStyleName:=tbl.TableStyle
End With
End With
tbl.Unlist
CloseRecordset:
rs.Close
Set rs = Nothing
CloseConnection:
conn.Close
Set conn = Nothing
conversiongl.Copy
With Workbooks(Workbooks.Count)
.SaveAs Filename:="E:\GL.glm", FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
End Sub
Function getGLSQL(tbl As ListObject) As String
Dim SQL As String, SheetName As String, RangeAddress As String
Dim strcur, strbranch, strSource, StrtimeStampDate As String
strcur = "'INR'"
strbranch = "'CHEN'"
strSource = "'Northern Arc'"
StrtimeStampDate = ThisWorkbook.Worksheets("sheet2").Range("b2").Value
SQL = " SELECT " & strbranch & " as [Branch]" & _
", " & strcur & " as [CURRENCY]" & _
", [NATURAL_ACCOUNT]" & _
", Left([gl_desc_2], 50) as [gl_desc_2]" & _
", IIF(isnull([AMT]), 0, [AMT]) as [AMT1]" & _
", IIF(isnull([AMT]), 0, [AMT]) as [AMT2]" & _
", " & strSource & " as [SOURCE] " & _
", " & StrtimeStampDate & " as [TimeStamp] " & _
" FROM" & _
"( SELECT sum([NET]) * -1 AS [AMT]" & _
", [NATURAL_ACCOUNT] as [NATURAL_ACCOUNT]" & _
", [gl_desc_2]" & _
" FROM [SheetName$RangeAddress] " & _
" group by ([natural_account]), [gl_desc_2] )"
'SQL = "Select [NATURAL_ACCOUNT] FROM [SheetName$RangeAddress] "
SheetName = tbl.Parent.Name
RangeAddress = tbl.Range.Address(False, False)
Debug.Print SheetName
Debug.Print RangeAddress
SQL = Replace(SQL, "SheetName", SheetName)
SQL = Replace(SQL, "RangeAddress", RangeAddress)
getGLSQL = SQL
End Function
Change
StrtimeStampDate = ThisWorkbook.Worksheets("sheet2").Range("b2").Value
To
StrtimeStampDate = "#" & Format(ThisWorkbook.Worksheets("sheet2").Range("b2").Value,"dd mmm yyyy") & "#"
Ok I am having a Problem using VBA from Excel 2010 to Query data in access, the problem comes when the variable Descripcheck, or Grouplocal, some of the descriptions have a "" in the excel cell so when it pulls the string itself this causes the query function gets a syntax error. Any ideas?
PMnum = Cells(B, 3)
Grouplocal = Cells(B, 4)
Descripcheck = Cells(B, 6)
DevTyp = Cells(B, 5)
TagName = Cells(B, 2)
If PMnum = "" Then
PMnum = " IS NULL"
Else:
PMnum = "=" & PMnum
End If
If Grouplocal = "" Then
Grouplocal = " IS NULL"
Else:
Grouplocal = "=" & Chr$(34) & Grouplocal & Chr$(34)
End If
If Descripcheck = "" Then
Descripcheck = " IS NULL"
Else:
Descripcheck = "=" & Chr$(34) & Descripcheck & Chr$(34)
End If
If DevTyp = "" Then
DevTyp = " IS NULL"
Else:
DevTyp = "=" & Chr$(34) & DevTyp & Chr$(34)
End If
If TagName = "" Then
TagName = " IS NULL"
Else:
TagName = "=" & Chr$(34) & TagName & Chr$(34)
End If
sCmndString = "SELECT Site_Data.Pass_Fail, Site_Data.Tag_Name, Site_Data.[PM_#],Site_Data.Group_Location_Reference, Site_Data.Device_Type, Site_Data.Description, Site_Data.Set_Point, Site_Data.Set_Point_Units, Site_Data.Fail_Low, Site_Data.Fail_High, Site_Data.As_Found, Site_Data.As_Left, Site_Data.Manufacturer_SN, Site_Data.Year_Put_Into_Service, Site_Data.Date_of_Test, Site_Data.Time_To_Complete, Site_Data.Service, Site_Data.Comments, Site_Data.Site, Site_Data.Year, Site_Data.Month " & _
"FROM Site_Data WHERE (((Site_Data.[PM_#])" & PMnum & ") AND " & _
"((Site_Data.Group_Location_Reference)" & Grouplocal & ") AND " & _
"((Site_Data.Device_Type)" & DevTyp & ") AND " & _
"((Site_Data.Description)" & Descripcheck & ") AND " & _
"((Site_Data.Site)=" & Chr$(34) & SiteName & Chr$(34) & ") AND " & _
"((Site_Data.Year)=" & Chr$(34) & yrs & Chr$(34) & ") AND " & _
"((Site_Data.Month)=" & Chr$(34) & Mnth & Chr$(34) & ") AND " & _
"((Site_Data.Tag_Name)" & TagName & "));"
Set rs = New ADODB.Recordset
rs.Open sCmndString, cnt, 2, 3, 1
If you keep fooling around with those "s and Chr$(34)s you'll drive yourself crazy. Try using a parameterized query instead. Consider the following (simplified) example. It uses some test data in Access...
Site_ID Device_Type Description
------- ----------- ------------
1 Type1 test1
2 Type1
3 Type1
4 Type2 "some" value
5 Type2 "some" value
6 Type2
7 Type2
8 Type2
...an Excel sheet that looks like this...
...and the code behind the button is
Option Explicit
Public Sub AccessLookup()
Dim con As ADODB.Connection, cmd As ADODB.Command, rst As ADODB.Recordset
Dim DevTyp As Variant, Descripcheck As Variant
Dim s As String, i As Long
s = Trim(CStr(Range("B1").Value))
DevTyp = IIf(Len(s) = 0, Null, s)
s = Trim(CStr(Range("B2").Value))
Descripcheck = IIf(Len(s) = 0, Null, s)
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\Public\Database1.accdb;"
Set cmd = New ADODB.Command
cmd.ActiveConnection = con
cmd.CommandText = _
"SELECT COUNT(*) AS n FROM Site_Data " & _
"WHERE Device_Type " & IIf(IsNull(DevTyp), "IS NULL ", "= ? ") & _
"AND Description " & IIf(IsNull(Descripcheck), "IS NULL ", "= ? ")
i = 0
If Not IsNull(DevTyp) Then
cmd.CreateParameter "?", adVarWChar, adParamInput, 255
cmd.Parameters(i).Value = DevTyp
i = i + 1
End If
If Not IsNull(Descripcheck) Then
cmd.CreateParameter "?", adVarWChar, adParamInput, 255
cmd.Parameters(i).Value = Descripcheck
i = i + 1
End If
Set rst = cmd.Execute
Range("B6").Value = rst("n").Value
rst.Close
Set rst = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
End Sub