speed88bump
New Member
- Joined
- Aug 9, 2013
- Messages
- 29
Synopsis: I have made an ODBC connection within an excel sheet that connects directly to the AS400 database. It brings it in as a table when refreshed. I am wanting to pass the parameters in the sheet to the AS400 and then refresh the data, as I have found this to be much faster and more efficient than returning the data cell by cell.
Problem/Opportunity: When the code reaches 'Clear Work Files it errors out and I do not think it is my library fields (now changed to xxx as it is proprietary) I think it may be as simple as a comma or bracket placed incorrectly towards the end of the statement.
Also, I am not sure I am even passing the parameters correctly. Parm1-3 will always reflect the same data. However, Parm4 it needs to go through each cell starting in A2 until Last Row and input that into AS400. My question here is how should it do that? Use a between statement (Between A2 and Last Row), Use an And Statement for each cell adding it to the query? List and list each part number from each cell?
The code below may have some extra Public Declarations in it but that is only because this code has changed so many times and I have not had a chance to go through them and clear the unused ones out.
I am a newbie so don't assume I know, please show me example in code.
Public i As Long
Public x As Long
Public FirstRow As Long
Public ChangeRow As Long
Public Lastrows As Long
Public HdrRowT As Long
Public HdrRowB As Long
Public Rng As Range
Public Row As Long
Public SystemAccess As String
Public LogIn As String
Public Userid As String
Public Pword As String
Public Lib As String
Public Libf As String
Public LibT As String
Public Libf1 As String
Public Parm1 As String
Public Parm2 As String
Public Parm3 As String
Public Parm4 As String
Public CloseLogInForm As String
Public ChagedCell As String
Public f As Long
Public t As Long
Public ClearSt As String
Sub Refresh_Data()
Dim svr As New ADODB.Connection
Dim Rs As ADODB.Recordset
Set My_Range = Range("A2:B" & LastRow(ActiveSheet))
My_Range.Parent.Select
'Verify connection to AS400
If LogIn <> "1" Then
Call Access
End If
'Control events in screen
ActiveSheet.Select
ActiveSheet.Unprotect
'Application.ScreenUpdating = False
'Application.EnableEvents = False
Lib = "XXXXXXX"
LibT = "XXXXXXX"
Libf = "XXXXXX"
svr.Open "provider=IBMDA400;data source=137.168.XXX.XXX;User ID=" & Userid & "; Password=" & Pword
If Err Then
MsgBox "Verify your credentials"
Exit Sub
End If
'Clear work files
'Set Rs = svr.Execute("{{CALL /XXXXXXX.LIB/" & Lib & ".LIB/XXXXXX.PGM}}," - 1, Rcds)
If Err Then
MsgBox Error
svr.Close
Exit Sub
End If
With Sheets("Data Input")
'loop through each cell starting in A2 until lRow is reached
lRow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & lRow)
Parm1 = Range("D2") 'Company
Parm2 = Range("E2") 'Route
Parm3 = Range("F2") 'Shrinkage
Parm4 = cell.Value 'Item#
'Send parameters from Worksheet to AS400 Program
Set Rs = svr.Execute("{{CALL /XXXXXXX.LIB/" & Lib & ".LIB/XXXXXX.PGM('" & Parm1 & "' '" & Parm2 & "' '" & Parm3 & "' '" & Parm4 & "')}}", -1, Rcds)
If Err Then
MsgBox Error
svr.Close
Exit Sub
End If
Exit For
Next cell
'Control events in screen
ActiveSheet.Select
There is a data connection already within the workbook so after the parameters have been passed the
Workbook refreshes that data connection with the new parameters
ActiveWorkbook.RefreshAll
End With
End Sub
Sub Access()
LogInForm.Show
'LogIn = LogInForm.logVal.Text
Userid = LogInForm.UserIdB.Text
Pword = LogInForm.PWordB.Text
SystemAccess = LogInForm.SystemButton1.Value
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Problem/Opportunity: When the code reaches 'Clear Work Files it errors out and I do not think it is my library fields (now changed to xxx as it is proprietary) I think it may be as simple as a comma or bracket placed incorrectly towards the end of the statement.
Also, I am not sure I am even passing the parameters correctly. Parm1-3 will always reflect the same data. However, Parm4 it needs to go through each cell starting in A2 until Last Row and input that into AS400. My question here is how should it do that? Use a between statement (Between A2 and Last Row), Use an And Statement for each cell adding it to the query? List and list each part number from each cell?
The code below may have some extra Public Declarations in it but that is only because this code has changed so many times and I have not had a chance to go through them and clear the unused ones out.
I am a newbie so don't assume I know, please show me example in code.
Public i As Long
Public x As Long
Public FirstRow As Long
Public ChangeRow As Long
Public Lastrows As Long
Public HdrRowT As Long
Public HdrRowB As Long
Public Rng As Range
Public Row As Long
Public SystemAccess As String
Public LogIn As String
Public Userid As String
Public Pword As String
Public Lib As String
Public Libf As String
Public LibT As String
Public Libf1 As String
Public Parm1 As String
Public Parm2 As String
Public Parm3 As String
Public Parm4 As String
Public CloseLogInForm As String
Public ChagedCell As String
Public f As Long
Public t As Long
Public ClearSt As String
Sub Refresh_Data()
Dim svr As New ADODB.Connection
Dim Rs As ADODB.Recordset
Set My_Range = Range("A2:B" & LastRow(ActiveSheet))
My_Range.Parent.Select
'Verify connection to AS400
If LogIn <> "1" Then
Call Access
End If
'Control events in screen
ActiveSheet.Select
ActiveSheet.Unprotect
'Application.ScreenUpdating = False
'Application.EnableEvents = False
Lib = "XXXXXXX"
LibT = "XXXXXXX"
Libf = "XXXXXX"
svr.Open "provider=IBMDA400;data source=137.168.XXX.XXX;User ID=" & Userid & "; Password=" & Pword
If Err Then
MsgBox "Verify your credentials"
Exit Sub
End If
'Clear work files
'Set Rs = svr.Execute("{{CALL /XXXXXXX.LIB/" & Lib & ".LIB/XXXXXX.PGM}}," - 1, Rcds)
If Err Then
MsgBox Error
svr.Close
Exit Sub
End If
With Sheets("Data Input")
'loop through each cell starting in A2 until lRow is reached
lRow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & lRow)
Parm1 = Range("D2") 'Company
Parm2 = Range("E2") 'Route
Parm3 = Range("F2") 'Shrinkage
Parm4 = cell.Value 'Item#
'Send parameters from Worksheet to AS400 Program
Set Rs = svr.Execute("{{CALL /XXXXXXX.LIB/" & Lib & ".LIB/XXXXXX.PGM('" & Parm1 & "' '" & Parm2 & "' '" & Parm3 & "' '" & Parm4 & "')}}", -1, Rcds)
If Err Then
MsgBox Error
svr.Close
Exit Sub
End If
Exit For
Next cell
'Control events in screen
ActiveSheet.Select
There is a data connection already within the workbook so after the parameters have been passed the
Workbook refreshes that data connection with the new parameters
ActiveWorkbook.RefreshAll
End With
End Sub
Sub Access()
LogInForm.Show
'LogIn = LogInForm.logVal.Text
Userid = LogInForm.UserIdB.Text
Pword = LogInForm.PWordB.Text
SystemAccess = LogInForm.SystemButton1.Value
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function