concatenation and max length of string in VBA, access - string

I've had severas problems with strings in access-vba.
The thing is, access (sometimes) limit the string's length to about 255 characters.
However, depending on HOW the string was built, it may be able to grow bigger then 255 chars.
There's an example of WORKING code :
Dim strReq as String
strReq = "SELECT exampleField1, exampleField2, exampleField3, exampleField4, exampleField5 "
strReq = strRec & ", exampleField6, exampleField7, exampleField8, .... [etc. insert many fields, you get it]"
strReq = strReq & " FROM myTable INNER JOIN Tbl2 ON ...[many JOINs as well]"
And so on, I often work with large queries so the 256 chars is easily busted.
However, these examples doesn't work :
Dim strReq as String
strReq = "SELECT exampleField1, exampleField2, exampleField3, exampleField4, exampleField5 " & _
", exampleField6, exampleField7, exampleField8, .... [etc. insert many fields, you get it]" & _
" WHERE exampleField1 = x AND exampleField2 = y AND exampleField3 = z" & _
" ORDER BY 1,2,3,4,5,6"
And this doesn't work either :
Dim strReq as String
Dim strWhere as String
strReq = "SELECT exampleField1, exampleField2, exampleField3, exampleField4, exampleField5 "
strReq = strRec & ", exampleField6, exampleField7, exampleField8, .... [etc. insert many fields, you get it]"
strWhere = "WHERE exampleField1 = x "
strWhere = strWhere & "AND exampleField2 = y"
strWhere= strWhere & " AND exampleField3 = z"
strReq = strReq & strWhere [& strJoin / strOrder / strHaving / etc]
I know know aproximatively how I can or cannot concatenate strings but I'd like to know how strings exactly work on access vba , because, i'll admit, it seems quite random so far...
*(Please note, these strings are supposed of longer length then the 255 characters AND the query is just there as an example, syntaxe mistakes or exact length in these are not the point here)
*Edit -- adding the code I'm actually using (With the working version, tried both bugging versions to clean up the code and both were bugging
strReq = "SELECT " & IIf(Len(rsRap.Fields("top")) > 0, " TOP " & rsRap.Fields("top"), "") & " " & rsRap.Fields("champs") & ", Sum([Canada]*[Quantité]) AS Montant, Sum(TblDetailCom.Quantité) AS Qty " & IIf(Len(rsRap.Fields("rep")) > 0, ", NickName", "")
strReq = strReq & " FROM (SELECT * FROM TblRepresentant WHERE RefRep not In(13,15,26,27,28)) AS TblRepresentant INNER JOIN "
strReq = strReq & " ((TblProduits LEFT JOIN TblTypBijoux ON TblProduits.Type = TblTypBijoux.IdTypBijoux) "
strReq = strReq & " INNER JOIN (TblCouleur INNER JOIN ((TblClients INNER JOIN ((TblComm LEFT JOIN RqMaxIdTrait ON TblComm.ID = RqMaxIdTrait.IdCommande) "
strReq = strReq & " LEFT JOIN TblTraitement ON RqMaxIdTrait.MaxOfIdTrait = TblTraitement.IdTrait) ON TblClients.ID = TblComm.RefClient) "
strReq = strReq & " INNER JOIN TblDetailCom ON TblComm.ID = TblDetailCom.RefCom) ON TblCouleur.ID = TblDetailCom.RefCoul) "
strReq = strReq & " ON TblProduits.IdMod = TblDetailCom.RefProd) ON TblRepresentant.RefRep = TblClients.RefRepre "
strReq = strReq & " WHERE (TblClients.RefRepre <> 5 OR (TblClients.RefRepre=5 AND TblClients.ID In (1210,219,189,578))) "
'(((TblProduits.Coll)=16) AND((TblComm.CoDatCom)>=#2011-01-01# And (TblComm.CoDatCom)<=#2014-01-01#) " 'Params Collection (16) DteDeb/fin
'strReq = strReq & " AND "
If Len(rsRap.Fields("type")) > 0 Then
strReq = strReq & " AND TblProduits.[Type] = " & rsRap.Fields("type")
End If
If Len(txtDe) > 0 Then
strReq = strReq & " AND TblTraitement.DtTrait >= #" & txtDe & "# "
End If
If Len(txtA) > 0 Then
strReq = strReq & " AND TblTraitement.DtTrait <= #" & txtA & "# "
End If
If Len(rsRap.Fields("pays")) > 0 Then
strReq = strReq & " AND TblClients.ClPaiePays = '" & rsRap.Fields("pays") & "' "
End If
If Len(rsRap.Fields("rep")) > 0 Then
strReq = strReq & " AND TblClients.RefRepre = " & rsRap.Fields("rep")
End If
If Len(rsRap.Fields("col")) > 0 Then
strReq = strReq & " AND TblProduits.Coll=" & rsRap.Fields("col")
End If
If Len(rsRap.Fields("group")) > 0 Then
strReq = strReq & " GROUP BY " & rsRap.Fields("group") & IIf(Len(rsRap.Fields("rep")) > 0, ", NickName", "")
End If
strReq = strReq & " HAVING Sum([Canada]*[Quantité]) >= 0 "
If Len(rsRap.Fields("order")) > 0 Then
strReq = strReq & " ORDER BY " & rsRap.Fields("order")
End If

You seem to accept the fact that a VBA string can contain more than 255 characters. As an example this code creates a 264 character string.
Const cstrSegment As String = "0123456789" & vbCrLf
Dim MyBigString As String
Dim i As Long
For i = 1 To 22
MyBigString = MyBigString & cstrSegment
Next
Debug.Print "Len(MyBigString): " & Len(MyBigString)
Rather you're encountering trouble based on the method you use to concatenate strings. I don't know where that trouble is exactly, but I can tell you there is a limit to the number of line continuations you can use when adding to a string. For example the following code compiles and runs without error. However if I add one more line continuation (& cstrSegment _), the compiler complains "Too many line continuations".
MyBigString = MyBigString & cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment _
& cstrSegment
If that describes the problem you're seeing, the limitation is based on line continuations, not string length. If needed, you could work around that limit by building the string in multiple steps. Do "MyBigString = MyBigString & cstrSegment _" up to the limit of line continuations, then add to MyBigString with another "MyBigString = MyBigString & cstrSegment _" block.
Make sure you're not misled by how many character you see. Perhaps the situation is you're only seeing the first 255 characters, but the string actually contains many more. That would make sense since you reported you're not getting an error building the string apparently fails.
Confirm the actual length of the string with Len():
Debug.Print "Len(MyBigString): " & Len(MyBigString)
You can also print the string's content to the Immediate window to see what it contains:
Debug.Print MyBigString
You can use Ctrl+g to open the Immediate window.

When concatenating strings for SQL, add a vbCrLf character when lines might grow long. Access seems to have trouble ingesting VBA strings (to execute as SQL) greater than about 1000 characters. e.g.
strSQL = strSQL & "SELECT some fields " & vbcrlf & "FROM some table "

Related

Excel VBA ADODB SQL connection doesn't run the whole execute command

Hey there I have a weird problem which I can't find its source. I have a messy code below which takes user input from one of the excel pages(kinda like a form) and creates a long sql query.
Everytime SQLstrL command gets updated within the Do While it basically adds another INSERT command to the SQLstrL string.
When I copy the sql query which VBA created via a function and paste on SSMS everything works like a charm. So I know there is nothing wrong with the command text. But when I try to execute from cn.Execute like below, It only executes first 4 INSERT commands of SQLstrL and ignores the rest. I have up to 60 INSERT commands within SQLstrL string.
I have no idea why this bizarre problem occurs. If anyone can help me I'll be most appreciated.
SQLStr = "DECLARE #newdatetime datetime; " & _
"DECLARE #newdatetimelong datetime; " & _
"DECLARE #timeint int; " & _
"DECLARE #newficheno varchar(17); " & _
"DECLARE #newlogref int; " & _
"SET #newficheno=(SELECT REPLICATE('0',LEN(LASTASGND)-LEN(LASTASGND+1))+REPLACE(STR(CONVERT(varchar,LASTASGND)+1),' ','') FROM L_LDOCNUM WHERE FIRMID=500 AND APPMODULE=1 AND DOCIDEN=12); " & _
"UPDATE L_LDOCNUM SET LASTASGND=#newficheno FROM L_LDOCNUM WHERE FIRMID=500 AND APPMODULE=1 AND DOCIDEN=12; " & _
"SET #newdatetime=CONVERT(datetime,'" & DateInp & "',104); " & _
"SET #timeint=LOGODB.dbo.LG_TIMETOINT(DATEPART(hour,GETDATE()),DATEPART(minute,GETDATE()),DATEPART(second,GETDATE())); " & _
"SET #newdatetimelong=#newdatetime+LOGODB.dbo.LG_INTTOTIME(#timeint); " & _
"INSERT INTO LG_500_01_STFICHE " & _
"SELECT 3,12,3, " & _
"#newficheno, " & _
"#newdatetime, " & _
"#timeint, " & _
"'','','','',0,0,0,0,0,0,'',0, " & _
"0,/*SOURCEINDEX*/ " & _
"0,0,0,/*SOURCECSTGRP*/ " & _
"0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,'','','','','','',1,0,0,0,0,0,0,1,#newdatetimelong,DATEPART(hour,#newdatetimelong),DATEPART(minute,#newdatetimelong),DATEPART(second,#newdatetimelong),0,NULL,0,0,0,0,0,'','','',/*TRACKNR*/ " & _
"3,0,'',0,0,1,0,0,0,0,0,0,'" & Worksheets("Form").Range("M1").Text & "',/*DOCTRACKINGNR*/ " & _
"0,0,'',0,0,0,'',0,'',0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,NULL,0,#newdatetime,#timeint,0,0,0,NEWID(),'',0,0,0,'',0,0,0,0,0,0,NULL,0,0,0,#newdatetime,#timeint, " & _
"0,0,'',0,'','',NULL,0,0,0,'','','','',0,0,'',0,NULL,0,NULL,0,0,0,0,0,0; " & _
"SET #newlogref=(SELECT LOGICALREF FROM LG_500_01_STFICHE WHERE TRCODE=12 AND FICHENO=#newficheno);"
Startsearch = Worksheets("Form").Range("A3").Address
Do While IsNumeric(Worksheets("Form").Range(Startsearch).Value) And Worksheets("Form").Range(Startsearch).Value <> ""
SQLStrL = SQLStrL & " INSERT INTO LG_500_01_STLINE " & _
" SELECT " & _
CDbl(Application.VLookup(Worksheets("Form").Range(Startsearch).Offset(0, 1).Text, Worksheets("Destek").ListObjects("Malzemeler").Range.Offset(0, 2), 5, False)) & "," & _
" 0,0,0,0,12,#newdatetime,#timeint,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4,#newlogref, " & _
CDbl(Worksheets("Form").Range(Startsearch).Value) & "," & _
" 0,0,0,0,0,0,0,406,0,0,0,0,0,0,0,'','', " & _
Replace(CDbl(Worksheets("Form").Range(Startsearch).Offset(0, 12).Value), ",", ".") & "," & _
" 0,0,0,0,0,0,1,0,0,0,0,0,'" & Worksheets("Form").Range(Startsearch).Offset(0, 6).Text & "', " & _
CDbl(Application.VLookup(CDbl(Application.VLookup(Worksheets("Form").Range(Startsearch).Offset(0, 1).Text, Worksheets("Destek").ListObjects("Malzemeler").Range.Offset(0, 2), 4, 0)) & "-" & Worksheets("Form").Range(Startsearch).Offset(0, 13).Text, Worksheets("Destek").ListObjects("UnitSet").Range, 5, 0)) & "," & _
CDbl(Application.VLookup(Worksheets("Form").Range(Startsearch).Offset(0, 1).Text, Worksheets("Destek").ListObjects("Malzemeler").Range.Offset(0, 2), 4, False)) & "," & _
" 1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,'',0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,'','',0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, " & _
" DATEPART(month,#newdatetimelong),DATEPART(year,#newdatetimelong), " & _
" 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,NULL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,'',0,0,NEWID(),'',0,0,'','',0,0,0,0,'',0,'','',0,0,'','',0,0,0,0,NULL,0,0,0,0,0,0,'','',0,0,0,0,0,0,NULL,0,0,0,0,0,0,0,0,0,'','','',NULL,0,0,0,0,0,0,0,0,0; " & vbNewLine
Startsearch = Worksheets("Form").Range(Startsearch).Offset(1, 0).Address
Loop
Set cn = New ADODB.Connection
cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
cn.Execute SQLStr & SQLStrL, , ADODB.ExecuteOptionEnum.adExecuteNoRecords

Procedure to import excel file to access is erroring out after loop - MS Access Error 91: Object variable or With block variable not set

I'm getting an error message after the last loop runs in this procedure.The error is received after it cycles through the last worksheet in the excel workbook, and the line is "xl.ActiveSheet.Next.Select" (line 17 from the bottom). Can anyone give me a pointer? I've read and been told using .select is not ideal, but this is an older database I have inherited and would like to resolve this issue before improving the code.
The loop opens up an excel file and cycles through each worksheet (24 in this workbook) and imports the data to an access database. I've searched this topic but many issues seem unrelated, or much simpler to debug. I've even removed all but two worksheets and the error is still repeatable. Any help is appreciated! Thanks!
Private Sub lbl_WV_import_Click()
If gcfHandleErrors Then On Error GoTo Err_frmMe_home_lbl_WV_import
Dim xl As Object, wrkbk1 As Object
Dim pcd As String, pcd_title As String, model As String, station As String, task As String, pic As String, bom_pn As String, c1 As String, c2 As String, spec As String, sApp As String
Dim pn As String, pname As String, ts_part_name As String, ts_part_num As String, model_info As String, color As String, dest As String, tool As String, socket As String, torque As String, misc As String
Dim rev As Integer, zone As Integer, seq As Integer, mod_id As Integer, delta As Integer, st_seq As Integer, qty As Integer, i As Integer, J As Integer, ts_sec As Integer, sec As Integer, row As Integer
Dim pcd_id As LongPtr, stat_id As LongPtr, task_id As LongPtr, task_list_id As LongPtr, pn_id As LongPtr, tool_id As LongPtr, task_step_id As LongPtr
Dim pitch As Double
Set db = CurrentDb()
sApp = "Excel.Application"
If IsAppRunning(sApp) = True Then
Set xl = GetObject(, "Excel.Application")
For Each wrkbk1 In xl.Workbooks
If wrkbk1.Name = "P1_PCD.xlsm" Then
Exit For
End If
Next
strSQL = DLookup("db_loc", "tbl_ext_source") & DLookup("area", "tblArea") & "\P1_PCD.xlsm"
Set wrkbk1 = xl.Workbooks.Open(strSQL)
Else
Set xl = CreateObject("Excel.Application")
xl.Application.Visible = True
strSQL = DLookup("db_loc", "tbl_ext_source") & DLookup("area", "tblArea") & "\P1_PCD.xlsm"
Set wrkbk1 = xl.Workbooks.Open(strSQL)
End If
xl.Workbooks("P1_PCD.xlsm").Activate
xl.Sheets(1).Select
xl.Range("B1").Select
pcd_title = xl.Range("B1").Value
xl.Range("O2").Select
pitch = xl.Range("O2").Value
xl.Range("Q2").Select
pcd = "PCD-" & xl.Range("Q2").Value
xl.Range("R2").Select
rev = xl.Range("R2").Value
xl.Range("K3").Select
model = xl.Range("K3").Value
If IsNull(DLookup("model", "tblModel", "[model] = '" & model & "'")) Then
strSQL = "INSERT INTO tblModel (model) " _
& "Values ('" & model & "')"
db.Execute strSQL
lid = DMax("mod_id", "tblModel")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblModel"", '" & lid & "', '" & fosUserName() & "', ""model"", ""New Record"", '" & model & "')"
db.Execute strSQL
End If
If IsNull(DLookup("pcd", "tblPCD", "pcd='" & pcd & "' AND rev=" & rev & "")) Then
mod_id = DLookup("mod_id", "tblModel", "[model] = '" & model & "'")
bom_pn = DLookup("ItemNo", "PYMAC", "LV = ""00""")
strSQL = "INSERT INTO tblPCD ( pcd, pcd_title, rev, mod_id, pitch, pre_rev, bom_pn ) " _
& "VALUES ('" & pcd & "','" & pcd_title & "', " & rev & ", " & mod_id & ", " & pitch & ", " & rev - 1 & ", '" & bom_pn & "')"
db.Execute strSQL
pcd_id = DLookup("pcd_id", "tblPCD", "pcd='" & pcd & "' AND rev=" & rev & "")
lid = DMax("pcd_id", "tblPCD")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblPCD"", '" & lid & "', '" & fosUserName() & "', ""ALL"", ""New Record"", ""New PCD from excel "" & " & pcd_id & ")"
db.Execute strSQL
Call upload_pymac(pcd_id)
Set db = CurrentDb()
Else
If InputBox("This PCD already exists. Is this another section of this PCD that needs to be imported? [Y/N]") = "y" Then
Else
Exit Sub
End If
End If
pcd_id = DLookup("pcd_id", "tblPCD", "pcd='" & pcd & "' AND rev=" & rev & "")
If IsNull(DMax("seq", "tblTask", "[pcd_id] = " & pcd_id & "")) Then
seq = 1
Else
seq = DMax("seq", "tblTask", "[pcd_id] = " & pcd_id & "")
End If
For J = 1 To xl.ActiveWorkbook.Worksheets.Count
xl.Range("O3").Select
station = xl.Range("O3").Value
If IsNull(DLookup("station", "tblStation", "[station] = '" & station & "'")) Then
If IsNull(DMax("stat_id", "tblStation")) Then
sec = 1
Else
sec = DMax("stat_id", "tblStation") + 1
End If
strSQL = "INSERT INTO tblStation ( station, zone_id,sec ) " _
& "VALUES ('" & station & "',1," & sec & ")"
db.Execute strSQL
lid = DMax("stat_id", "tblStation")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblStation"", '" & lid & "', '" & fosUserName() & "', ""ALL"", ""New Records"", ""New record for PCD "" & " & pcd_id & ")"
db.Execute strSQL
End If
stat_id = DLookup("stat_id", "tblStation", "[station] = '" & station & "'")
st_seq = 1
c1 = "C6"
xl.Range(c1).Select
Do Until xl.CountA(xl.ActiveCell) = 0
xl.Range(c1).Select
task = xl.ActiveCell.Value
If Len(task) > 250 Then
task = Left(task, 255)
End If
If IsNull(DLookup("task_txt", "tblTask_txt", "[task_txt] = '" & task & "'")) Then
strSQL = "INSERT INTO tblTask_txt ( task_txt ) " _
& "VALUES ('" & task & "')"
db.Execute strSQL
lid = DMax("task_list_id", "tblTask_txt")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblTask_txt"", '" & lid & "', '" & fosUserName() & "', ""task_txt"", ""New Record"", '" & task & "')"
db.Execute strSQL
End If
task_list_id = DLookup("task_list_id", "tblTask_txt", "[task_txt] = '" & task & "'")
xl.ActiveCell.Offset(0, 4).Select
If xl.ActiveCell.Value = "Q" Then
delta = 1
ElseIf xl.ActiveCell.Value = "C" Then
delta = 2
ElseIf xl.ActiveCell.Value = "CTQ" Then
delta = 3
ElseIf xl.ActiveCell.Value = "R" Then
delta = 4
Else
delta = 0
End If
xl.ActiveCell.Offset(0, 1).Select
spec = Replace(xl.ActiveCell.Value, "'", "''")
If Len(spec) > 250 Then
spec = Left(spec, 255)
End If
strSQL = "INSERT INTO tblTask ( pcd_id, seq, stat_id, task_list_id, st_seq, spec_inst ) " _
& "Values (" & pcd_id & ", " & seq & ", " & stat_id & ", " & task_list_id & "," & st_seq & ", '" & spec & "')"
db.Execute strSQL
task_id = DMax("task_id", "tblTask")
lid = DMax("task_id", "tblTask")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblTask_txt"", '" & lid & "', '" & fosUserName() & "', ""ALL"", ""New Record"", ""New record for PCD "" & " & pcd_id & ")"
db.Execute strSQL
row = xl.ActiveCell.row()
c2 = "E" & row
xl.Range(c2).Select
strSQL = DLookup("db_loc", "tbl_ext_source") & DLookup("area", "tblArea") & "\PICS\" & task_id & ".jpg"
xl.Run "getpic", strSQL
For i = 1 To 10
c2 = "K" & row & ":" & "T" & row
If xl.CountA(xl.Range(c2)) = 0 Then
Exit For
End If
c2 = "K" & row
xl.Range(c2).Select
c2 = xl.ActiveCell.Address
ts_part_num = ""
ts_part_name = ""
pn = ""
pname = ""
pn_id = 0
tool = ""
tool_id = 0
pname = xl.ActiveCell.Value
If pname = "Part Name" Then
Exit For
End If
xl.ActiveCell.Offset(0, 1).Select
pn = xl.ActiveCell.Value
If IsNull(DLookup("part_num", "tblPart_master", "[part_num] = '" & pn & "'")) Then
ts_part_num = pn
ts_part_name = pname
Else
pn_id = DLookup("pn_id", "tblPart_master", "[part_num] = '" & pn & "'")
End If
xl.ActiveCell.Offset(0, 1).Select
qty = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
model_info = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
color = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
dest = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
tool = xl.ActiveCell.Value
If Len(tool) > 1 Then
If IsNull(DLookup("tool_id", "tblTools", "[tool] = '" & tool & "'")) Then
strSQL = "INSERT INTO tblTools (tool, tool_type_id ) " _
& "Values ('" & tool & "',1)"
db.Execute strSQL
lid = DMax("tool_id", "tblTools")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblTools"", '" & lid & "', '" & fosUserName() & "', ""tool"", ""New Record"", '" & tool & "')"
db.Execute strSQL
End If
tool_id = DLookup("tool_id", "tblTools", "[tool] = '" & tool & "'")
End If
xl.ActiveCell.Offset(0, 1).Select
socket = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
torque = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
misc = xl.ActiveCell.Value
strSQL = "INSERT INTO tblTask_steps ( task_id ) " _
& " Values ( " & task_id & " )"
db.Execute strSQL
task_step_id = DMax("task_step_id", "tblTask_steps")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblTask_steps"", '" & task_step_id & "', '" & fosUserName() & "', ""ALL"", ""New Record"", ""New record for PCD "" & " & pcd_id & ")"
db.Execute strSQL
strSQL = "SELECT tblTask_steps.* " _
& "FROM tblTask_steps " _
& "WHERE (((tblTask_steps.task_step_id)=" & task_step_id & "))"
Set rs = db.OpenRecordset(strSQL)
If Len(ts_part_name) > 0 Then
rs.Edit
rs!ts_part_name = ts_part_name
rs.Update
End If
If Len(ts_part_num) > 0 Then
rs.Edit
rs!ts_part_num = ts_part_num
rs.Update
End If
If pn_id > 0 Then
rs.Edit
rs!pn_id = pn_id
rs.Update
End If
If qty > 0 Then
rs.Edit
rs!qty = qty
rs.Update
End If
If Len(model_info) > 0 Then
rs.Edit
rs!model_info = model_info
rs.Update
End If
If Len(color) > 0 Then
rs.Edit
rs!color = color
rs.Update
End If
If Len(dest) > 0 Then
rs.Edit
rs!dest = dest
rs.Update
End If
If tool_id > 0 Then
rs.Edit
rs!tool_id = tool_id
rs.Update
End If
If Len(socket) > 0 Then
rs.Edit
rs!socket = socket
rs.Update
End If
If Len(torque) > 0 Then
rs.Edit
rs!torque = torque
rs.Update
End If
If delta > 0 Then
rs.Edit
rs!delta = delta
rs.Update
End If
If Len(misc) > 0 Then
rs.Edit
rs!misc = misc
rs.Update
End If
xl.Range(c2).Select
xl.ActiveCell.Offset(1, 0).Select
row = xl.ActiveCell.row()
Next i
ts_sec = 0
xl.Range(c1).Select
xl.ActiveCell.Offset(1, 0).Select
If xl.ActiveCell.Column() <> 3 Then
row = xl.ActiveCell.row()
c1 = "C" & row + 1
xl.Range(c1).Select
End If
If xl.ActiveCell.Value = "Task Description" Then
xl.ActiveCell.Offset(1, 0).Select
If xl.ActiveCell.Column() <> 3 Then
row = xl.ActiveCell.row()
c1 = "C" & row + 1
xl.Range(c1).Select
End If
End If
If IsEmpty(xl.ActiveCell) Then
strSQL = DLookup("db_loc", "tbl_ext_source") & DLookup("area", "tblArea") & "\PICS\" & task_id & "_2.jpg"
xl.Run "getpic", strSQL
xl.ActiveCell.Offset(1, 0).Select
If xl.ActiveCell.Column() <> 3 Then
row = xl.ActiveCell.row()
c1 = "C" & row + 1
xl.Range(c1).Select
End If
End If
If xl.ActiveCell.Value = "Task Description" Then
xl.ActiveCell.Offset(1, 0).Select
If xl.ActiveCell.Column() <> 3 Then
row = xl.ActiveCell.row()
c1 = "C" & row + 1
xl.Range(c1).Select
End If
End If
c1 = xl.ActiveCell.Address
st_seq = st_seq + 1
seq = seq + 1
Loop
xl.ActiveSheet.Next.Select
Next J
xl.Application.ScreenUpdating = True
strSQL = "UPDATE tblTask SET tblTask.image_id = [task_id] " _
& "WHERE (((tblTask.pcd_id)=" & pcd_id & "))"
db.Execute strSQL
Call recal_secs(1, pcd_id, 0)
Call sort_stat_all(pcd_id)
MsgBox "The PCD has been imported. Go to stations and assure the zones are correct."
Set rs = Nothing
Set db = Nothing
Exit_frmMe_home_lbl_WV_import:
Exit Sub
Err_frmMe_home_lbl_WV_import:
Call LogError(Err.Number, Err.Description, "frmMe_home_lbl_WV_import()")
Resume Exit_frmMe_home_lbl_WV_import
End Sub
As I tried suggesting in my above comment, it looks that the way you designed the code (probably, mostly based on macro recorder...), using an unjustified number of selecting, makes the code erroring on the respective line because of the fact that a Next sheet does not exist after the last one...
If you want keeping the code as it is and only solve the error, please, try inserting above the problematic code line, the next one:
If J = xl.ActiveWorkbook.Worksheets.Count Then Exit For
But your code is not efficient, at all. The next part, for instance:
xl.Workbooks("P1_PCD.xlsm").Activate
xl.Sheets(1).Select
xl.Range("B1").Select
pcd_title = xl.Range("B1").value
should be replaced with the more efficient one, not involving any Activation/selection:
Dim ws As Object
Set ws = xl.Workbooks("P1_PCD.xlsm")
pcd_title = ws.Range("B1").value
Then, the way of looping between the sheets is also not efficient. Activating the sheet and selecting any range to be used only consumes Excel resources. Instead of the way you use:
For J = 1 To xl.ActiveWorkbook.Worksheets.Count
you can do it in a different, more efficient way:
Dim sh As Object
For each sh in xl.ActiveWorkbook.Worksheets
station = sh.Range("O3").Value
'your code...
'instead of
'xl.Range(c1).Select
'task = xl.ActiveCell.Value
'you should use:
task = sh.Range(c1).Value ' or better
task = sh.Range("C6").Value 'and eliminate c1 useless variable...
'it is at least strange to use
'c1 = "C" & row + 1
'xl.Range(c1).Select
'instead of directly:
sh.Range("C" & row + 1) 'selection is useless, anyhow...
Next sh
Your code is too long, you do not explain in words what you want accomplishing and I cannot spend too much time to deduce what you try doing. I am only suggesting some things necessary to be changed in order to improve the code quality and speed...

VBA Adodb : concatenation of values

I would like to use in my query the key like this: '"prod.cd_produit"'||'"/"'||'" & strQ & "'.
Here, the values of my variables are: prod.cd_produit= 53 and & strQ & =350, so I would like to have 53/350 as a key.
I'm wondering if it's right to write '"prod.cd_produit"'||'"/"'||'" & strQ & "' (I don't want to have any spaces neither at right nor at left). This is a part of my code :
Public Sub INFO_PROTO34(ByRef strQ As String)
...........................................
" sousc.lp_etat_doss not in ('ANNUL','A30','IMPAY') and sousc.is_produit = prod.is_produit" & _
" and '"prod.cd_produit"'||'"/"'||'" & strQ & "' = proto.cd_protocole ",
Thank you very much for your help!
Like this:
RECSET.Open " select proto.b_perf_cma as b_perf_cma from db_dossier sousc,db_produit prod, " & _
" db_protocole proto where sousc.no_police = '" & numero_de_police & "' " & _
" and sousc.cd_dossier = 'SOUSC' " & _
" and sousc.lp_etat_doss not in ('ANNUL','A30','IMPAY') " & _
" and sousc.is_produit = prod.is_produit " & _
" and prod.cd_produit||'/'||'" & strQ & "' = proto.cd_protocole ", _
cnn_Pegase, adOpenDynamic, adLockBatchOptimistic
helps to spend some time formatting your SQL so it's more readable (for us and you...)

using two recordset vba excel

I have this code
Public Sub CommandButton1_Click()
Cells.Clear
Dim oConn1 As ADODB.Connection
Dim rs1 As ADODB.Recordset
Dim rs2 As ADODB.Recordset
Set oConn1 = New ADODB.Connection
oConn1.ConnectionString = "Provider=SQLOLEDB.1;Password=" & Contraseña.Text & ";Persist Security Info=True;User ID= " & Usuario.Text & "; Initial Catalog =" & bases.Text & ";Data Source= SERVER\BD;"
oConn1.ConnectionTimeout = 200
oConn1.Open
Set rs1 = New ADODB.Recordset
rs1.ActiveConnection = oConn1
rs1.Source = "DECLARE #id INT" & _
"SET #id = ##spid" & _
"INSERT CLIENTES_SALDOS_E (PROCESO_ID, CODIGO_DE_CLIENTE)" & _
"SELECT #id, CODIGO_DE_CLIENTE" & _
"FROM CLIENTES" & _
"WHERE CLIENTES.CODIGO_DE_CLIENTE BETWEEN '" & EXTRA(Ncuenta) & "' AND '" & EXTRA(Ncuenta2) & "'" & _
"EXECUTE sp_Reconstruccion_saldo_doctos "", '" & EXTRA(Fechacorte) & "', #id"
Set rs2 = New ADODB.Recordset
rs2.ActiveConnection = oConn1
rs2.Source = "SELECT P.NOMBRE_DEPARTAMENTO,M.NOMBRE_MUNICIPIO,R.NOMBRE_TERRITORIO,V.NOMBRE_VENDEDOR,C.CODIGO_DE_CONDICION,E.CODIGO_DE_CLIENTE,C.NOMBRE_CLIENTE,D.CODIGO_MOVIMIENTO," & _
"D.SERIE_DEL_DOCUMENTO,D.NUMERO_DOCUMENTO,(ME.MONTO_TOTAL * ME.CAMBIO_MONEDA_LOCAL) AS MONTO_MONEDA_LOCAL,D.SALDO_MONEDA_LOCAL,CONVERT(VARCHAR(10),D.FECHA_DOCUMENTO,103) AS FECHA_DOCUMENTO," & _
"CONVERT(VARCHAR(10),D.FECHA_VENCIMIENTO,103) AS FECHA_VENCIMIENTO,D.DIAS_DE_ANTIGUEDAD," & _
"CASE WHEN D.DIAS_DE_ANTIGUEDAD =0 THEN D.SALDO_MONEDA_LOCAL ELSE 0 END AS 'NO VENCIDO'," & _
"CASE WHEN D.DIAS_DE_ANTIGUEDAD >=1 AND D.DIAS_DE_ANTIGUEDAD <=15 THEN D.SALDO_MONEDA_LOCAL ELSE 0 END AS 'DE 1 A 15 DIAS'," & _
"CASE WHEN D.DIAS_DE_ANTIGUEDAD >=16 AND D.DIAS_DE_ANTIGUEDAD <=30 THEN D.SALDO_MONEDA_LOCAL ELSE 0 END AS 'DE 16 A 30 DIAS'," & _
"CASE WHEN D.DIAS_DE_ANTIGUEDAD >=31 AND D.DIAS_DE_ANTIGUEDAD <=60 THEN D.SALDO_MONEDA_LOCAL ELSE 0 END AS 'DE 31 A 60 DIAS'," & _
"CASE WHEN D.DIAS_DE_ANTIGUEDAD >=61 AND D.DIAS_DE_ANTIGUEDAD <=90 THEN D.SALDO_MONEDA_LOCAL ELSE 0 END AS 'DE 61 A 90 DIAS'," & _
"CASE WHEN D.DIAS_DE_ANTIGUEDAD >=91 AND D.DIAS_DE_ANTIGUEDAD <=9999 THEN D.SALDO_MONEDA_LOCAL ELSE 0 END AS 'DE 91 A 9999 DIAS'" & _
"FROM CLIENTES C" & _
"INNER JOIN CLIENTES_SALDOS_E E ON E.CODIGO_DE_CLIENTE = C.CODIGO_DE_CLIENTE" & _
"INNER JOIN CLIENTES_SALDOS_D D ON D.CODIGO_DE_CLIENTE = E.CODIGO_DE_CLIENTE AND D.PROCESO_ID = E.PROCESO_ID" & _
"INNER JOIN MOVIMIENTOS_TIPO T ON T.CODIGO_MOVIMIENTO = D.CODIGO_MOVIMIENTO" & _
"INNER JOIN DEPARTAMENTOS P ON C.CODIGO_DE_PAIS = P.CODIGO_DE_PAIS AND C.CODIGO_DEPARTAMENTO = P.CODIGO_DEPARTAMENTO" & _
"INNER JOIN MUNICIPIOS M ON C.CODIGO_DE_PAIS = M.CODIGO_DE_PAIS AND C.CODIGO_DEPARTAMENTO = M.CODIGO_DEPARTAMENTO AND C.CODIGO_MUNICIPIO = M.CODIGO_MUNICIPIO" & _
"INNER JOIN TERRITORIOS R ON C.CODIGO_TERRITORIO = R.CODIGO_TERRITORIO" & _
"LEFT JOIN CLIENTE_VENDEDOR CV ON C.CODIGO_DE_CLIENTE = CV.CODIGO_DE_CLIENTE" & _
"LEFT JOIN VENDEDORES V ON CV.CODIGO_VENDEDOR = V.CODIGO_VENDEDOR" & _
"INNER JOIN MOVIMIENTO_ENC ME ON D.SERIE_DEL_DOCUMENTO = ME.SERIE_DEL_DOCUMENTO AND D.NUMERO_DOCUMENTO = ME.NUMERO_DOCUMENTO AND D.CODIGO_MOVIMIENTO = ME.CODIGO_MOVIMIENTO" & _
"WHERE E.PROCESO_ID = #id AND T.TIPO_TRANSACCION = 'S' AND D.ID_EMPRESA = 'GN' AND D.ID_SUCURSAL = '01' AND D.ID_CENTRO_OPERATIVO = '001' AND D.SALDO_MONEDA_LOCAL > 0" & _
"DELETE CLIENTES_SALDOS_E WHERE PROCESO_ID = #id" & _
"DELETE CLIENTES_SALDOS_D WHERE PROCESO_ID = #id"
rs2.Open
encabezados
Range("A2").CopyFromRecordset rs2
'a = rs1.Fields.Count
rs1.Close
rs2.Close
oConn1.Close
MsgBox ("Reporte Generado")
Set rs1 = Nothing
Set rs2 = Nothing
Set oConn1 = Nothing
End If
End Sub
When i run this code, give me a incorrect syntax near 'E' error, I divided the code in two recordset because in only one give me the error: there is to many continuation of lines, but now i have incorrect syntax error.
I guess the error is because in the where clause of the recordset 2, makes reference to the variable declared on the recordset 1, and i dont know how tell the query to the E.PROCESO_ID is in the recordset 1.
How can i fix this?
Thanks
My best guess is the problem is missing spaces here. Right now your statement reads
FROM CLIENTES CINNER JOIN CLIENTES_SALDOS
but it should read
FROM CLIENTES C INNER JOIN CLIENTES_SALDOS
So add a space in front of every INNER JOIN.

Why does my script seem to randomly truncate strings?

The script below basically takes a source table and a target table and copies all the records. It works fairly well, but one recurring issue I'm having is that it seems to truncate some strings. Here is one of the error outputs:
Error Number: -2147217900 Description: [Microsoft][ODBC SQL Server
Driver][SQL S erver]Unclosed quotation mark after the character string
'STRINGSEGMENT^urn:uuid:e9 e91fe151-5w4c-12e1-bac5-25b3a0'.
INSERT INTO TableName VALUES ('23189','23189','','','1^^','','12/5/2013 3:37:2 2
PM','fieldvalue','','somethinghere','somethinghere','12/5/2013 9:37:22
AM','123456','1234568798','STRINGSEGMENT^urn:uuid:
e91fe151-5w4c-12e1-bac5-25b3a0
Query is 584 characters long
If you look at the source data, the string that is truncated looks something like this:
STRINGSEGMENT^urn:uuid:e91fe151-5w4c-12e1-bac5-25b3a0004b00^STRINGSEGMENT
So it's cutting it off after the 53rd character (highlighted). The entire length of tSQL is only 584 characters long.
Why is this happening?
WScript.Echo "Setting Vars..."
Dim sConnect, tConnect, resultSet, r
Dim sDSN, sUserName, sPassWord
Dim tDSN, tUserName, tPassWord
Dim value
sDSN = "mydsn"
sUsername = "myusername"
sPassword = "mypassword"
tDSN = "LOCAL"
tUsername = "myusername"
tPassword = "mypassword"
sTable = "sourceTable"
tTable = "targetTable"
sSQL = "" 'see below
sDSN = "DSN=" & sDSN & ";UID=" & sUsername & ";PWD=" & sPassword & ";"
tSQL = "Select TOP 1 ID FROM " & tTable & " ORDER BY ID Desc"
tDSN = "DSN=" & tDSN & ";UID=" & sUsername & ";PWD=" & sPassword & ";"
Set sConnect = CreateObject("ADODB.Connection")
WScript.Echo "Opening connection to source..."
sConnect.Open sDSN
Set tConnect = CreateObject("ADODB.Connection")
WScript.Echo "Opening connection to target..."
tConnect.Open tDSN
WScript.Echo "Finding Current Record..."
Set r = tConnect.Execute(tSQL)
On Error Resume Next
r.MoveFirst
if r.eof Then currentRecord = 1
Err.Clear
Do While Not r.eof
currentRecord = r("ID") + 1
r.MoveNext
Loop
r.Close
sSQL ="Select * FROM " & sTable & " WHERE ID >= " & currentRecord
WScript.Echo "Beginning shadow at record " & currentRecord & "..."
Set resultSet = sConnect.Execute(sSQL)
resultSet.MoveFirst
Do While Not resultSet.eof
On Error Resume Next
tSQL = "INSERT INTO " & tTable & " VALUES ('"
For i = 0 To resultSet.fields.Count - 1
if NOT IsNull(resultSet(i)) Then
value = replace(resultSet(i),"'","")
'somewhere around here
else
value = ""
End If
tSQL = tSQL & value
if i < resultSet.fields.Count - 1 Then
tSQL = tSQL & "','"
end if
Next
tSQL = tSQL & "')"
'when the error occurs, the line above doesn't seem to be processed but the line below obviously is...
tConnect.Execute(tSQL)
If (Err.Number <> 0) Then
WScript.Echo "Error Number: " & Err.Number & " Description: " & Err.Description
WScript.Echo tSQL
WScript.Echo "Query is " & Len(tSQL) & " characters long"
WScript.StdIn.ReadLine
Err.Clear
End If
tSQL = ""
resultSet.MoveNext
Loop
resultSet.Close
sConnect.Close
Set sConnect = Nothing
tConnect.Close
Set tConnect = Nothing
WScript.Quit(0)
I don't know why this is happening, but here is my workaround. I will not accept this as an answer, just wanted to document.
Function allowed(n)
allowed = true
if n = 13 Then allowed = false
if n = 14 Then allowed = false
End Function
Function sanitize(v,i) 'v=value i=index
mystr = ""
if allowed(i) Then
if Not IsNull(v) Then
mystr = replace(v,"'","")
End If
end if
sanitize = mystr
End Function
Basically I'm just manually excluding the columns that have a problem. Notice that I identified a second one. What's really curious is that columns 12 and 13 have identical data in the source database, but column 12 copies fine.

Resources