Macro to run multiple queries

[asreid2527]

Hi,

I have a spreadsheet that has individual queries that are each on a separate worksheet. Each worksheet has the following code belowto automatically connect and run the query and return results to the worksheet. Since there are over 60 queries, I would like to be able to just click one button to run all queries. They have to run individually, so I am unsure how to write anything that would tell it to run the next query when the previous one finishes.

Any help would be greatly appreciated, thanks

Dim strDatabaseName As String
Dim strDBCursorType As String
Dim strDBLockType As String
Dim strDBOptions As String
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection

Public strUserName
Public strPassword
Public ch
 
Sub get_data()

Dim srt As Object
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
'Msg = "Date you entered, already exists. Do you want to clear old data ?"
'Style = vbYesNo + vbCritical + vbDefaultButton2
'Title = "Warning"

Ctxt = 1000
ch = 0

If Sheets(ActiveSheet.Name).Range("E3") = "Specific Date" Then
    date1 = Sheets(ActiveSheet.Name).Range("E4")
ElseIf Sheets(ActiveSheet.Name).Range("E3") = "Range" Then
    date1 = date1 = Sheets(ActiveSheet.Name).Range("E5")
    date2 = date1 = Sheets(ActiveSheet.Name).Range("G5")
End If
   

strDBCursorType = adOpenDynamic  'CursorType
strDBLockType = adLockOptimistic   'LockType
strDBOptions = adCmdText         'Options

'UserForm1.Show

Application.ScreenUpdating = False
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Please be patient..."

If ch = 1 Then Exit Sub 'not sure what this is for [BB]

Set cn = New ADODB.Connection
'Me.MousePointer = 11
On Error GoTo f:
cn.Open ConnectString()
    
On Error GoTo 0
    With cn
        .CommandTimeout = 0
        .CursorLocation = adUseClient
    End With

    Set rs = New ADODB.Recordset



'If Sheets("DATA").Range("a5") <> "" Then
'                Set tbl = Sheets("DATA").Range("a5").CurrentRegion
'        tbl.Offset(1, 0).Resize(tbl.Rows.Count + 5, tbl.Columns.Count).Clear
'End If



   


Dim Cnct2Z As String ', s2 As String


's1 = query codes
s1 = Sheets(ActiveSheet.Name).txtSQL.Text
          
          
'replace placeholders with dates
If Sheets(ActiveSheet.Name).Range("E3") = "Specific Date" Then
    s1 = Replace(s1, "date1", "'" & date1 & "'")
ElseIf Sheets(ActiveSheet.Name).Range("E3") = "Range" Then
    s1 = Replace(s1, "date1", "'" & date1 & "'")
    s1 = Replace(s1, "date2", "'" & date2 & "'")
End If

Debug.Print s1
      
'Set MyR2 = MyCn2Z.mbOpenRecordset(s1 & s2, dbOpenSnapshot, dbExecDirect)
rs.Open s1, cn, strDBCursorType, strDBLockType, strDBOptions
a = rs.RecordCount
            

            
'row_cnt = Sheets(ActiveSheet.Name).Range("L15").CurrentRegion.Rows.Count
'Sheets("data").Select
'Range(Cells(9, 1), Cells(row_cnt, 50)).ClearContents

'data should be stored starting in cell L15
Sheets(ActiveSheet.Name).Range("L3:BI65000").ClearContents

Set fc = Sheets(ActiveSheet.Name).Range("L3")
'Set fc = Sheets("data").Range("a8:a650000").Find("")
If Not fc Is Nothing Then
    fc.Offset.CopyFromRecordset rs
    Sheets(ActiveSheet.Name).Range("L3:BI65000").RowHeight = 15
Else
    MsgBox ("Can't find an empty cell to place the data") 'shouldn't happen, data is cleared first
End If
            
rs.Close
cn.Close
Set cn = Nothing
            
Application.ScreenUpdating = True
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

'mark query as run
Sheets(ActiveSheet.Name).Range("F21") = Date & " " & Time

Exit Sub

f:

MsgBox ("Cannot connect to PostgeSQL server. Check the configuration information; including the username and password.")
          
Application.ScreenUpdating = True
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

End Sub

Private Function ConnectString() As String
Dim strServerName As String
Dim strDatabaseName As String
Dim strUserName As String
Dim strPassword As String

    'Change to IP Address if not on local machine
    'Make sure that you give permission to log into the

    'server from this address
    'See Adding New User Accounts to MySQL
    'Make sure that you d/l and install the MySQL Connector/ODBC 3.51 Driver

strServerName = Sheets(ActiveSheet.Name).Range("B3")
strDatabaseName = Sheets(ActiveSheet.Name).Range("B4")
strport = Sheets(ActiveSheet.Name).Range("B5")
strUserName = Sheets(ActiveSheet.Name).Range("B6")
strPassword = Sheets(ActiveSheet.Name).Range("B7")

ConnectString = "DRIVER={PostgreSQL}; SERVER=" & strServerName & ";DATABASE=" & strDatabaseName & ";" & "UID=" & strUserName & ";PASSWORD=" & strPassword & ";port=" & strport & ";OPTION=1;"
             
           
             
End Function