Link to home
Start Free TrialLog in
Avatar of Luis Diaz
Luis DiazFlag for Colombia

asked on

VBA: Select SQL query based on a config Sheet v2

Hello Experts,

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

Open in new window

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

Open in new window


Config Sheet:
User generated image
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

Open in new window


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
Avatar of Rgonzo1971
Rgonzo1971

Hi,

pls try

Sub SQLQueryOut2(wsName As String, strSQL, strInitialRange, strServer)


Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver=" & strServer & ";" & _
"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
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("E" & 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

Open in new window

Regards
Avatar of Luis Diaz

ASKER

Thank you very much for your proposal.

1-Why strServer is placed in the driver parameter?

Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver=" & strServer & ";" & _
"Server=IPSERVER;" & _

Open in new window


I tested with the following and it works:
Set objConn = CreateObject("ADODB.Connection")
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

Open in new window


as I have the following error message:
User generated image
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")

Open in new window

Here is the revised code (Omit flag) is placed in column

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 = 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

Open in new window


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

Open in new window

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").CurrentRegion.Rows.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:=Sheets(wb.Sheets.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.User generated image.

Thank you again for your help.
then try
DestSh.Name = wsConfig.Range("A" & rw).Value

Open in new window

Thank you for this proposal.

I added the line and the new worksheet is added in the workbook with the correct name however I got an stop with and error message related to:
User generated image
The problem concerns a Run-time error '13' type mismatch.

Do you know why?
then try
If Range("D" & rw) Then

Open in new window

since you already have controlled Range "A" & rw
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.
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.

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

Open in new window

ASKER CERTIFIED SOLUTION
Avatar of Rgonzo1971
Rgonzo1971

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
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").Select 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:=Sheets(wb.Sheets.Count))
        DestSh.Name = wsName
        wsConfig.Select
    Else
        Sheets(wsName).Cells.ClearContents
        wsConfig.Select
    End If
   
Set objRS = CreateObject("ADODB.Recordset")


Set objConn = CreateObject("ADODB.Connection")
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(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"
        End If
    Next rw
    MsgBox "Tables reported in Config have been updated"
    wsConfig.Select
End Sub



Thank you again for your help!