Luis Diaz
asked on
VBA: Select SQL query based on a config Sheet v2
Hello Experts,
I have the following procedure reported at:
Dim rw
Config Sheet:
I would like to improve the procedure in order to add the following:
1-Be able to report in Column E of Config Sheet the server concern by the query (The other parametes such as User, database will be directly reported in the procedure and not in the file.
2-Add and if condition concerning the Destination worksheet. If the reported Destination worksheet doesn’t exist the procedure should be able to create it.
Reference :
3-Add a flag in Column D in order to bypass one of the Query if startFlag=1 omit the query to export and continue to the next line else take into account the reference line.
I attached the dummy file. If you have questions, please contact me.
Thank you very much for your help.
28935856_Funct-select-query-based-c.xlsm
I have the following procedure reported at:
https://www.experts-exchange.com/questions/28935856/VBA-Excel-SQL-Select-Query-based-on-a-config-sheet.html
which allows me to config a Select sql query based on multiple parameters. Dim rw
Sub SQLQueryOut2(wsName As String, strSQL, strInitialRange)
Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver={SQL Server};" & _
"Server=IPSERVER;" & _
"UID=USER;" & _
"PWD=PASSWORD;" & _
"Database=DATABASE;"
Dim objRS
Set objRS = CreateObject("ADODB.Recordset")
Dim SQL
SQL = strSQL
objRS.Open SQL, objConn
On Error Resume Next
Set rs = objConn.Execute(SQL)
On Error GoTo 0
If rs Is Nothing Then
MsgBox "SQL query reported at row " & rw & " is not properly set up unable to transfer data."
Exit Sub
End If
Sheets(wsName).Cells.ClearContents
For Idx = 1 To rs.Fields.Count
Sheets(wsName).Range(strInitialRange).Offset(0, Idx - 1) = rs.Fields(Idx - 1).Name
Next
Sheets(wsName).Range(strInitialRange).Offset(1).CopyFromRecordset rs
Set objRS = Nothing
Set objConn = Nothing
End Sub
Sub SQLQueryoutConfigSheet()
Dim wsConfig As Worksheet, wsResult As Worksheet
Set wsConfig = Worksheets("Config")
Application.ScreenUpdating = False
For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
If Evaluate("=ISREF('" & Range("A" & rw) & "'!A1)") And Range("D" & rw) Then
SQLQueryOut2 Range("A" & rw), Range("B" & rw), Range("C" & rw)
Else
MsgBox "Reported sheet: " & Range("A" & rw) & "doesn't exist!"
Exit Sub
End If
Next rw
wsConfig.Select
End Sub
Config Sheet:
I would like to improve the procedure in order to add the following:
1-Be able to report in Column E of Config Sheet the server concern by the query (The other parametes such as User, database will be directly reported in the procedure and not in the file.
2-Add and if condition concerning the Destination worksheet. If the reported Destination worksheet doesn’t exist the procedure should be able to create it.
Reference :
Set wb = ActiveWorkbook
Set CfgSH = wb.Sheets("Config")
For Each c In CfgSH.Range(CfgSH.Range("A2"), CfgSH.Range("A" & Rows.Count).End(xlUp))
'===========================================================
'1)-->Add the DestinationWorksheet if doesn't exist
'===========================================================
Set DestSh = Nothing
On Error Resume Next
Set DestSh = wb.Sheets(c.Offset(0, 1).Value)
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
DestSh.Name = c.Offset(0, 1).Value
Else
DestSh.UsedRange.Clear
End If
3-Add a flag in Column D in order to bypass one of the Query if startFlag=1 omit the query to export and continue to the next line else take into account the reference line.
I attached the dummy file. If you have questions, please contact me.
Thank you very much for your help.
28935856_Funct-select-query-based-c.xlsm
ASKER
Thank you very much for your proposal.
1-Why strServer is placed in the driver parameter?
I tested with the following and it works:
Set objConn = CreateObject("ADODB.Connec tion")
objConn.Open "Driver={SQL Server};" & _
"Server=" & strServer & ";" & _
I also was forced to comment the following:
as I have the following error message:
Do you know why?
Last modification that I forgot.
3-I was wondering if we can report in column G for every SQL row last Run with the following format:
Thank you again for your help.
1-Why strServer is placed in the driver parameter?
Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver=" & strServer & ";" & _
"Server=IPSERVER;" & _
I tested with the following and it works:
Set objConn = CreateObject("ADODB.Connec
objConn.Open "Driver={SQL Server};" & _
"Server=" & strServer & ";" & _
I also was forced to comment the following:
Set DestSh = Nothing
On Error Resume Next
Set DestSh = wsName
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
DestSh.Name = wsName
Else
Sheets(wsName).Cells.ClearContents
End If
as I have the following error message:
Do you know why?
Last modification that I forgot.
3-I was wondering if we can report in column G for every SQL row last Run with the following format:
"Last Run: " & Format(Date, "DD/MM/YY") _
& "_" & "" & Format(Now, "HH-MM-SS")
Here is the revised code (Omit flag) is placed in columnSub SQLQueryOut2(wsName As String, strSQL, strInitialRange, strServer)
Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver={SQL Server};" & _
"Server=" & strServer & ";" & _
"UID=//User//r;" & _
"PWD=//Password//;" & _
"Database=//Database//;"
Dim objRS
Set objRS = CreateObject("ADODB.Recordset")
Dim SQL
SQL = strSQL
objRS.Open SQL, objConn
On Error Resume Next
Set rs = objConn.Execute(SQL)
On Error GoTo 0
If rs Is Nothing Then
MsgBox "SQL query reported at row " & rw & " is not properly set up unable to transfer data."
Exit Sub
End If
Set DestSh = Nothing
On Error Resume Next
Set DestSh = wsName
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
DestSh.Name = wsName
Else
Sheets(wsName).Cells.ClearContents
End If
For Idx = 1 To rs.Fields.Count
Sheets(wsName).Range(strInitialRange).Offset(0, Idx - 1) = rs.Fields(Idx - 1).Name
Next
Sheets(wsName).Range(strInitialRange).Offset(1).CopyFromRecordset rs
Set objRS = Nothing
Set objConn = Nothing
End Sub
Sub SQLQueryoutConfigSheet()
Dim wsConfig As Worksheet, wsResult As Worksheet
Set wsConfig = Worksheets("Config")
Application.ScreenUpdating = False
For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
If Range("F" & rw) <> 1 Then
If Evaluate("=ISREF('" & Range("A" & rw) & "'!A1)") And Range("D" & rw) Then
SQLQueryOut2 Range("A" & rw), Range("B" & rw), Range("C" & rw), Range("E" & rw)
Else
MsgBox "Reported sheet: " & Range("A" & rw) & "doesn't exist!"
Exit Sub
End If
End If
Next rw
wsConfig.Select
End Sub
Thank you again for your help.
then try
Sub SQLQueryOut2(wsName As String, strSQL, strInitialRange, strServer)
Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver={SQL Server};" & _
"Server=" & strServer & ";" & _
"UID=//User//r;" & _
"PWD=//Password//;" & _
"Database=//Database//;"
Dim objRS
Set objRS = CreateObject("ADODB.Recordset")
Dim SQL
SQL = strSQL
objRS.Open SQL, objConn
On Error Resume Next
Set rs = objConn.Execute(SQL)
On Error GoTo 0
If rs Is Nothing Then
MsgBox "SQL query reported at row " & rw & " is not properly set up unable to transfer data."
Exit Sub
End If
Set DestSh = Nothing
On Error Resume Next
Set DestSh = Sheets(wsName)
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
DestSh.Name = wsName
Else
Sheets(wsName).Cells.ClearContents
End If
For Idx = 1 To rs.Fields.Count
Sheets(wsName).Range(strInitialRange).Offset(0, Idx - 1) = rs.Fields(Idx - 1).Name
Next
Sheets(wsName).Range(strInitialRange).Offset(1).CopyFromRecordset rs
Set objRS = Nothing
Set objConn = Nothing
End Sub
Sub SQLQueryoutConfigSheet()
Dim wsConfig As Worksheet, wsResult As Worksheet
Set wsConfig = Worksheets("Config")
Application.ScreenUpdating = False
For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
If Range("F" & rw) <> 1 Then
If Evaluate("=ISREF('" & Range("A" & rw) & "'!A1)") And Range("D" & rw) Then
SQLQueryOut2 Range("A" & rw), Range("B" & rw), Range("C" & rw), Range("E" & rw)
Else
MsgBox "Reported sheet: " & Range("A" & rw) & "doesn't exist!"
Exit Sub
End If
End If
Next rw
wsConfig.Select
End Sub
ASKER
Thank you for this proposal. I will test it in a while?
I was trying to add the condition directly within the Config Loop but I don't know why it doesn't work:
Sub SQLQueryoutConfigSheet()
Dim wsConfig As Worksheet, wsResult As Worksheet
Set wb = ActiveWorkbook
Set wsConfig = Worksheets("Config")
Application.ScreenUpdating = False
For rw = 2 To wsConfig.Range("A1").Curre ntRegion.R ows.Count
If Range("F" & rw) <> 1 Then
'========================= ========== ========== ========== ====
'1)-->Add the DestinationWorksheet if doesn't exist
'========================= ========== ========== ========== ====
Set DestSh = Nothing
On Error Resume Next
Set DestSh = wb.Sheets(Range("A" & rw).Value)
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheet s(wb.Sheet s.Count))
DestSh.Name = Range("A" & rw).Value
Else
DestSh.UsedRange.Clear
End If
If Evaluate("=ISREF('" & Range("A" & rw) & "'!A1)") And Range("D" & rw) Then
SQLQueryOut2 Range("A" & rw), Range("B" & rw), Range("C" & rw), Range("E" & rw)
Else
MsgBox "Unable to properly launch the Query"
Exit Sub
End If
End If
Next rw
wsConfig.Select
End Sub
I got the following message thought a new sheet is added however I am not able to apply the name reported in the ConfigSheet..
Thank you again for your help.
I was trying to add the condition directly within the Config Loop but I don't know why it doesn't work:
Sub SQLQueryoutConfigSheet()
Dim wsConfig As Worksheet, wsResult As Worksheet
Set wb = ActiveWorkbook
Set wsConfig = Worksheets("Config")
Application.ScreenUpdating
For rw = 2 To wsConfig.Range("A1").Curre
If Range("F" & rw) <> 1 Then
'=========================
'1)-->Add the DestinationWorksheet if doesn't exist
'=========================
Set DestSh = Nothing
On Error Resume Next
Set DestSh = wb.Sheets(Range("A" & rw).Value)
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheet
DestSh.Name = Range("A" & rw).Value
Else
DestSh.UsedRange.Clear
End If
If Evaluate("=ISREF('" & Range("A" & rw) & "'!A1)") And Range("D" & rw) Then
SQLQueryOut2 Range("A" & rw), Range("B" & rw), Range("C" & rw), Range("E" & rw)
Else
MsgBox "Unable to properly launch the Query"
Exit Sub
End If
End If
Next rw
wsConfig.Select
End Sub
I got the following message thought a new sheet is added however I am not able to apply the name reported in the ConfigSheet..
Thank you again for your help.
then try
DestSh.Name = wsConfig.Range("A" & rw).Value
ASKER
then try
If Range("D" & rw) Then
since you already have controlled Range "A" & rw
ASKER
Thank you very much for this proposal.
Unable to test the complete procedure right now. I will test it on Monday.
Thank you again for your help.
Unable to test the complete procedure right now. I will test it on Monday.
Thank you again for your help.
ASKER
Hello,
Ok I tested this last version and I simplify the code but I am having a little problem. The code works perfectly when the reference worksheet exists however when the worksheet doesn't exist I have a connection failed though I used exactly the same authentication.
I don't if the best is to launch a procedure at the beginning to check if worksheet exists if not create it for all the various worksheet and then we launch the SQLQueryOut2 procedure. Thank you again for your help.
Ok I tested this last version and I simplify the code but I am having a little problem. The code works perfectly when the reference worksheet exists however when the worksheet doesn't exist I have a connection failed though I used exactly the same authentication.
I don't if the best is to launch a procedure at the beginning to check if worksheet exists if not create it for all the various worksheet and then we launch the SQLQueryOut2 procedure. Thank you again for your help.
Sub SQLQueryOut2(wsName As String, strSQL, strInitialRange, strServer)
Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver={SQL Server};" & _
"Server=" & strServer & ";" & _
"UID=//;" & _
"PWD=//;" & _
"Database=//;"
Dim objRS
Set wb = ActiveWorkbook
Set objRS = CreateObject("ADODB.Recordset")
Dim SQL
SQL = strSQL
objRS.Open SQL, objConn
On Error Resume Next
Set rs = objConn.Execute(SQL)
On Error GoTo 0
If rs Is Nothing Then
MsgBox "SQL query reported at row " & rw & " is not properly set up unable to transfer data."
Exit Sub
End If
Set DestSh = Nothing
On Error Resume Next
Set DestSh = Sheets(wsName)
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
DestSh.Name = wsName
Else
Sheets(wsName).Cells.ClearContents
End If
For Idx = 1 To rs.Fields.Count
Sheets(wsName).Range(strInitialRange).Offset(0, Idx - 1) = rs.Fields(Idx - 1).Name
Next
Sheets(wsName).Range(strInitialRange).Offset(1).CopyFromRecordset rs
Set objRS = Nothing
Set objConn = Nothing
End Sub
Sub SQLQueryoutConfigSheet()
Dim wsConfig As Worksheet, wsResult As Worksheet
Set wb = ActiveWorkbook
Set wsConfig = Worksheets("Config")
Application.ScreenUpdating = False
For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
If Range("E" & rw) <> 1 Then
SQLQueryOut2 Range("A" & rw), Range("B" & rw), Range("C" & rw), Range("D" & rw)
Range("F" & rw).Value = "Last Run: " & Format(Date, "DD/MM/YY") _
& "_" & "" & Format(Now, "HH-MM-SS")
Else
'MsgBox Range("B" & rw) & "is omitted du to flag reported"
Exit Sub
End If
Next rw
wsConfig.Select
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Ok, Thank you very much for this proposal.
I just made a modification concerning the loop condition when worksheet doesn't exist. I added
Worksheets("Config").Selec t in order to go back to the Config Sheet and it works!
Revised Code.
Sub SQLQueryOut2(wsName As String, strSQL, strInitialRange, strServer)
Dim objRS
Dim SQL
Set wb = ActiveWorkbook
Set DestSh = Nothing
On Error Resume Next
Set DestSh = Sheets(wsName)
Set wsConfig = Worksheets("Config")
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheet s(wb.Sheet s.Count))
DestSh.Name = wsName
wsConfig.Select
Else
Sheets(wsName).Cells.Clear Contents
wsConfig.Select
End If
Set objRS = CreateObject("ADODB.Record set")
Set objConn = CreateObject("ADODB.Connec tion")
objConn.Open "Driver={SQL Server};" & _
"Server=" & strServer & ";" & _
"UID=//;" & _
"PWD=//;" & _
"Database=//;"
SQL = strSQL
objRS.Open SQL, objConn
On Error Resume Next
Set rs = objConn.Execute(SQL)
On Error GoTo 0
If rs Is Nothing Then
MsgBox "SQL query reported at row " & rw & " is not properly set up unable to transfer data."
Exit Sub
End If
For Idx = 1 To rs.Fields.Count
Sheets(wsName).Range(strIn itialRange ).Offset(0 , Idx - 1) = rs.Fields(Idx - 1).Name
Next
Sheets(wsName).Range(strIn itialRange ).Offset(1 ).CopyFrom Recordset rs
Set objRS = Nothing
Set objConn = Nothing
End Sub
Sub SQLQueryoutConfigSheet()
Dim wsConfig As Worksheet, wsResult As Worksheet
Set wb = ActiveWorkbook
Set wsConfig = Worksheets("Config")
Application.ScreenUpdating = False
For rw = 2 To wsConfig.Range("A1").Curre ntRegion.R ows.Count
If Range("E" & rw) <> 1 Then
SQLQueryOut2 Range("A" & rw), Range("B" & rw), Range("C" & rw), Range("D" & rw)
Range("F" & rw).Value = "Last Run: " & Format(Date, "DD/MM/YY") _
& "_" & "" & Format(Now, "HH-MM-SS")
Else
'MsgBox Range("B" & rw) & " is omitted du to flag reported"
End If
Next rw
MsgBox "Tables reported in Config have been updated"
wsConfig.Select
End Sub
Thank you again for your help!
I just made a modification concerning the loop condition when worksheet doesn't exist. I added
Worksheets("Config").Selec
Revised Code.
Sub SQLQueryOut2(wsName As String, strSQL, strInitialRange, strServer)
Dim objRS
Dim SQL
Set wb = ActiveWorkbook
Set DestSh = Nothing
On Error Resume Next
Set DestSh = Sheets(wsName)
Set wsConfig = Worksheets("Config")
On Error GoTo 0
If DestSh Is Nothing Then
Set DestSh = wb.Sheets.Add(After:=Sheet
DestSh.Name = wsName
wsConfig.Select
Else
Sheets(wsName).Cells.Clear
wsConfig.Select
End If
Set objRS = CreateObject("ADODB.Record
Set objConn = CreateObject("ADODB.Connec
objConn.Open "Driver={SQL Server};" & _
"Server=" & strServer & ";" & _
"UID=//;" & _
"PWD=//;" & _
"Database=//;"
SQL = strSQL
objRS.Open SQL, objConn
On Error Resume Next
Set rs = objConn.Execute(SQL)
On Error GoTo 0
If rs Is Nothing Then
MsgBox "SQL query reported at row " & rw & " is not properly set up unable to transfer data."
Exit Sub
End If
For Idx = 1 To rs.Fields.Count
Sheets(wsName).Range(strIn
Next
Sheets(wsName).Range(strIn
Set objRS = Nothing
Set objConn = Nothing
End Sub
Sub SQLQueryoutConfigSheet()
Dim wsConfig As Worksheet, wsResult As Worksheet
Set wb = ActiveWorkbook
Set wsConfig = Worksheets("Config")
Application.ScreenUpdating
For rw = 2 To wsConfig.Range("A1").Curre
If Range("E" & rw) <> 1 Then
SQLQueryOut2 Range("A" & rw), Range("B" & rw), Range("C" & rw), Range("D" & rw)
Range("F" & rw).Value = "Last Run: " & Format(Date, "DD/MM/YY") _
& "_" & "" & Format(Now, "HH-MM-SS")
Else
'MsgBox Range("B" & rw) & " is omitted du to flag reported"
End If
Next rw
MsgBox "Tables reported in Config have been updated"
wsConfig.Select
End Sub
Thank you again for your help!
pls try
Open in new window
Regards