Koble til database

Option Explicit

Sub UpdateAirEmissionFromTeams()
    Dim ws As Worksheet
    Dim Query As String
    Dim StartRow As Long

    Set ws = Sheet1
    ws.Activate
    StartRow = 2

    ' Query = "SELECT t2.PERIOD_YEAR ""År"", t2.PERIOD_MONTH ""Måned"", t2.TASKID ""Oppdr. nr."", " & _
                    "s.name ""Verk"", pr.NAME_NB_NO ""Prosess"", se.NAME_NB_NO ""Seksjon"", l.NAME ""Lokasjon"", " & _
                    "t2.SAMPLEDATEFROM ""Prøvestart"", t2.SAMPLEDATETO ""Prøvestopp"", m.NAME ""Målepunkt"", " & _
                    "t2.SAMPLEID ""Prøveid"", mt.NAME_NB_NO ""Anleggsdel"", st.NAME_NB_NO ""Prøvetype"", " & _
                    "t2.""Comment"" ""Kommentar"", t2.TEMPERATURE_VALUE ""Kanaltemperatur"", " & _
                    "t2.AIRFLOWRATE_VALUE ""Volumstrøm [Nm3/h]"", t2.SAMPLEGASVOLUME_VALUE ""Abs. gass [Nm3]"", " & _
                    "p.NAME_NB_NO ""Komponent"", t2.CONCENTRATION_VALUE ""Kons. (tot) [mg/Nm3]"", " & _
                    "t2.CONCENTRATIONGAS_VALUE ""Kons. (gassf.) [mg/Nm3]"", t2.CONCENTRATIONPART_VALUE ""Kons. (part.) [mg/Nm3]"", " & _
                    "t2.EMISSIONFLOWRATE_VALUE ""Rate (tot) [kg/h]"", t2.EMISSIONFLOWRATEGAS_VALUE ""Rate (gassf.) [kg/h]"", " & _
                    "t2.EMISSIONFLOWRATEPART_VALUE ""Rate (part.) [kg/h]"", t2.CREATEDDATETIME ""Opprettet"", p.ORDERNUMBER ""PAH #"" " & _
            "FROM TEAMSSR.AIREMISSIONANALYSISPAHOUTPUT t2, TEAMSSR.SAMPLETYPE st, TEAMSSR.MEASUREMENTTYPE mt, " & _
                    "TEAMSSR.LOCATION l, TEAMSSR.SITE s, TEAMSSR.PROCESS pr, TEAMSSR.MEASUREMENTPOINT m, TEAMSSR.SECTION se, " & _
                    "TEAMSSR.POLLUTANT p " & _
            "WHERE s.name = 'Årdal' and t2.LOCATIONID = l.ID and t2.SAMPLETYPEID = st.ID " & _
                    "and t2.PROCESSID = pr.ID and t2.SECTIONID = se.ID and t2.POLLUTANTID = p.ID and t2.MEASUREMENTTYPEID = mt.ID " & _
                    "and t2.MEASUREMENTPOINTID = m.ID and t2.PERIOD_YEAR >= '2016'"

    Query = "SELECT t2.YEAR ""År"", t2.MONTH ""Måned"", p.NAME_NB_NO ""Komponent"", " & _
                    "s.NAME ""Verk"", mp.NAME ""Målepunkt"", AVG(t2.CONCENTRATION_VALUE) ""Konsentrasjon"" " & _
            "FROM TEAMSSR.WATERDISCHARGEANALYSISOUTPUT t2, TEAMSSR.site s, TEAMSSR.pollutant p, TEAMSSR.MEASUREMENTPOINT mp " & _
            "WHERE t2.siteid = s.id  and t2.pollutantid = p.id and t2.measurementpointid = mp.id " & _
                    "and s.NAME_NB_NO='Årdal' and t2.samplingdate>={ts'2016-01-01 00:00:00'} " & _
            "GROUP BY t2.YEAR, t2.MONTH, p.NAME_NB_NO, s.NAME, mp.NAME ORDER BY t2.YEAR"

    Call GetDataFunc("TEAMS", Query, ws, "AirEmissionTable", "A", StartRow)

End Sub
Private Sub GetDataFunc(Enhet As String, Query As String, ws As Worksheet, TableName As String, TableStartColumn As String, TableStartRow As Long)
    Dim DNSname As String, UIDname As String, PWDname As String, DBQname As String
    Dim dbConnectStr As String
    Dim conn As Object: Set conn = CreateObject("ADODB.Connection")
    Dim recset As Object: Set recset = CreateObject("ADODB.Recordset")
    Dim ErrorTag As Boolean
    Dim i As Long, lastRow As Long, lastColumn As Long
    Dim arrResults As Variant
    Dim tblRange As String

    Exit Sub
    If Enhet = "TEAMS" Then
        DNSname = "TEAMS"
        UIDname = "xxx"
        PWDname = "xxx"
        DBQname = "P090.HYDRO.COM"
    Else
        ufFeilMedODBC.Show
        Exit Sub
    End If

    dbConnectStr = "DSN=" & DNSname & ";UID=" & UIDname & ";PWD=" & PWDname & ";DBQ=" & DBQname

    conn.ConnectionString = dbConnectStr
    conn.Open dbConnectStr
    conn.CommandTimeout = 999999

    recset.CursorType = 2
    recset.Open Query, conn

    For i = 0 To recset.Fields.Count - 1
        Range(TableStartColumn & TableStartRow).Offset(0, i).Value = recset.Fields(i).Name
    Next i

    ws.Range(TableStartColumn & TableStartRow + 1).CopyFromRecordset (recset)
    recset.MoveFirst

    arrResults = recset.GetRows
    lastRow = UBound(arrResults, 2) + TableStartRow + 1

    recset.Close

    lastColumn = recset.Fields.Count + Range(TableStartColumn & 1).Column - 1
    tblRange = Range(Range(TableStartColumn & TableStartRow), Cells(lastRow, lastColumn).Address).AddressLocal
    On Error Resume Next
    ws.ListObjects.Add(xlSrcRange, Range(tblRange), , xlYes).Name = TableName

    DNSname = Null
    arrResults = Null
    UIDname = Null
    PWDname = Null
    DBQname = Null
    tblRange = Null
    lastRow = Null
    lastColumn = Null
    Query = ""
    recset = Null
End Sub