Running a database query is corrupting formulas

[RichardMGreen]

Hi all

I must admit this one is an poser!
I've got some code (courtesy of Norie) that loops through a load of queries names and runs them from a database.
The code is :

Sub Import_data()
    Dim conn As ADODB.Connection, rs As ADODB.Recordset, cmd As ADODB.Command, strConn As String
    Dim wsData As Worksheet, wsDst As Worksheet
    Dim rngData As Range, rngDst As Range
    Dim strQry As String, strSQL As String, file As String
    Dim param1, param2
'----- Clear out old data -----
    start_time = Now
    Application.Calculation = xlCalculationManual
    Sheets("Participation_Data_Sheet").Rows("3:1000").ClearContents
    Sheets("Participation_Eng_Data_Sheet").Rows("2:1000").ClearContents
    Sheets("Add_QDOS_Totals_Data_Sheet").Rows("3:1000").ClearContents
    Sheets("Ops_Add_Data_Sheet").Range("D3:EK30000").ClearContents
    Sheets("Office_Add1_Data_Sheet").Range("D3:DY30000").ClearContents
    Sheets("Office_Add2_Data_Sheet").Rows("3:1000").ClearContents
    Sheets("Ops_-_Exceptions_Data_Sheet").Rows("3:1000").ClearContents
    Sheets("Magnaclean_Data_Sheet").Rows("2:1000").ClearContents
    Sheets("Actuals_Data_Sheet").Rows("4:1000").ClearContents
    Sheets("Hydroflow_Data_Sheet").Rows("2:1000").ClearContents
    Sheets("QDOS_Data_Sheet").Rows("4:1000").ClearContents
    Sheets("Exceptions_Data_Sheet").Rows("4:1000").ClearContents
    Sheets("Forecast_&_Diary_Data_Sheet").Rows("4:1000").ClearContents  '----- Done -----

    Sheets("Names_Completed_Data_Sheet").Rows("4:1000").ClearContents
    Sheets("Add_QDOS_Data_Sheet").Rows("4:1000").ClearContents
    Sheets("Names_QDOS_Data_Sheet").Rows("4:1000").ClearContents
'----- Check local copy of database exists and has been updated today -----
    Set wsData = Worksheets("Validation_Data_Sheet")
    file = wsData.Range("N3") & wsData.Range("N5") & wsData.Range("N7")
    If Not FileExists(file) Then
        response = MsgBox("Heating Upgrades database not in expected location" & Chr(10) & _
            "Please make a local copy before proceeding", vbOKOnly, _
            "Unable to proceed")
        Exit Sub
    End If
    If Format(Last_Modified(file), "dd/mm/yyyy") <> Format(Date, "dd/mm/yyyy") Then
        response = MsgBox("Heating Upgrades database has not been copied today" & Chr(10) & _
            "Please make a new copy before proceeding", vbOKOnly, _
            "Unable to proceed")
        Exit Sub
    End If
'----- Set up objects ready for retrieving data -----
    Set wsData = Worksheets("Queries_Data_Sheet")
    Set conn = New ADODB.Connection
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & file & ";Persist Security Info=False;"
    conn.ConnectionString = strConn
    conn.Open
    Set rngData = wsData.Range("B2")
    Set cmd = New ADODB.Command
'----- Set up parameters and run until no more queries -----
    While rngData.Value <> ""
        param1 = "": param2 = "": param3 = "": param4 = "": param5 = "": param6 = ""
        strQry = "[" & rngData.Value & "]"
        param1 = rngData.Offset(, 1).Value
        param2 = rngData.Offset(, 2).Value
        param3 = rngData.Offset(, 3).Value
        param4 = rngData.Offset(, 4).Value
        param5 = rngData.Offset(, 5).Value
        param6 = rngData.Offset(, 6).Value
        strSQL = "SELECT * FROM " & strQry
        offsetrow = 1
'----- Link queries where posible to bring back as much data as possible in one go -----
        While rngData.Offset(offsetrow, -1) = "Y"
            strQry = "[" & rngData.Offset(offsetrow, 0) & "]"
            strSQL = strSQL & " union all SELECT * FROM " & strQry
            offsetrow = offsetrow + 1
        Wend
        cmd.CommandType = adCmdText
        cmd.CommandText = strSQL
        cmd.ActiveConnection = conn
'----- Pass parameters if needed/available -----
        If param1 <> "" Then cmd.Parameters(0) = param1
        If param2 <> "" Then cmd.Parameters(1) = param2
        If param3 <> "" Then cmd.Parameters(2) = param3
        If param4 <> "" Then cmd.Parameters(3) = param4
        If param5 <> "" Then cmd.Parameters(4) = param5
        If param6 <> "" Then cmd.Parameters(5) = param6
'----- Pick up information on where data is to go -----
        Set wsDst = Worksheets(rngData.Offset(, 7).Value)
        Set rngDst = wsDst.Range(rngData.Offset(, 8).Value)
'----- Retrieve data from database and insert into correct cells -----
        Set rs = cmd.Execute
        rngDst.CopyFromRecordset rs
'----- Make sure no data left to write and set up details for next query -----
        Set rs = Nothing
        Set rngData = rngData.Offset(offsetrow)
        wsData.Calculate
    Wend
    Set conn = Nothing
'    Application.Calculate
    Application.Calculation = xlCalculationAutomatic
'    Sheets("Cover_Page").Select
    end_time = Now
    MsgBox (start_time & " to " & end_time)
End Sub

Now, when it hits a the query on row 14, the formulas that supply the inputs for the queries in column F are erroring.
The formula in cells F2 is
=iso_week(TODAY()-7)

and the formula in cells F2 is
=iso_week(TODAY())

iso_week is a UDF to give me the week number to supply to the queries. The code for the UDF is :-

'----- get ISO week for any given date -----
Function ISO_Week(input_date)
    start_of_year = DateValue("01/01/" & Year(input_date))
    While Format(start_of_year, "Dddd") <> "Sunday"
        start_of_year = start_of_year + 1
    Wend
    If start_of_year > input_date Then
        start_of_year = DateValue("01/01/" & Year(input_date) - 1)
        While Format(start_of_year, "Dddd") <> "Sunday"
            start_of_year = start_of_year + 1
        Wend
    End If
    ISO_Week = (Year(start_of_year) * 10000) + 1000 + Int(((input_date - start_of_year) + 1) / 7) + 1
End Function

I can think of any reason for the query to make the formula error out as it's not being changed.

Anyone any ideas?

 

[RichardMGreen]

Also as part of the above, I have a query that has a second prompt on it.
I need to feed the prompt something to bring back all records, but when I leave it blank or put a "*" in it, it treats them as exact values and brings back nothing.

Anyone any ideas?

 

[RichardMGreen]

Anyone? Please?