Pasted

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