------ UPDATE ------

I am not sure what the correct way to do this is, but I have updated my code and will paste the new code.

My Worksheet Activate sub now looks like this:

Public Sub Worksheet_Activate() 'Removes shapes already there that will be updated by the getWeather function DeleteShapes 'Calls a function to get weather data from a web service. 'I tried not using the "Call" keyword, but that gives me an error message saying that I need to have this when calling a sub with more than one argument? Call GetWeather("url", "Area1") Call GetWeather("url", "Area2") Call GetWeather("url", "Area3") 'fill lists with information FillLists End Sub 

Here is the sub that deletes the shapes made by the last GetWeather update.

Public Sub DeleteShapes() Dim delShape As Shape For Each delShape In ARK_front.Shapes If delShape.Type = msoAutoShape Then delShape.Delete Next delShape End Sub 

Here is the GetWeather Sub

Public Sub GetWeather(APIurl As String, sted As String) Dim i As Integer Dim ws As Worksheet: Set ws = ActiveSheet Dim city, omraade As String Dim Req As New XMLHTTP Dim Weather As IXMLDOMNode Dim wShape As Shape Dim thisCell As Range Dim Resp As New DOMDocument i = 0 omraade = "" omraade = sted Select Case omraade Case "Area1" i = 4 Case "Area2" i = 6 Case "Area3" i = 8 Case Else Exit Sub End Select Req.Open "GET", "" & APIurl & "", False Req.Send Resp.LoadXML Req.responseText For Each Weather In Resp.getElementsByTagName("current_condition") Set thisCell = ws.Range(Cells(2, i), Cells(2, i)) Set wShape = ws.Shapes.AddShape(msoShapeRectangle, thisCell.Left, thisCell.Top, thisCell.Width, thisCell.Height) wShape.Fill.UserPicture Weather.ChildNodes(4).Text 'img Cells(3, i).Value = "" & Weather.ChildNodes(7).Text * 0.28 & " m/s" 'windspeedkmph Cells(4, i).Value = Weather.ChildNodes(9).Text 'Direction Cells(5, i).Value = Weather.ChildNodes(1).Text & " C" 'observation time Next Weather End Sub 

And here is the sub to fill the listboxes

Public Sub FillLists() 'I cannot run this sub with Option Explicit. It tells me I have a "Invalid inside procedure". And I cant for the life of me figure out what or where that is. 'Option Explicit ' I have to declare the formattedStartDate and formattedEndDate as String and not Date, because no matter what I try it forces the Date variable to format as dd/mm/yyyy even if I use format("","mm/dd/yyy"), which does not work with the access SQL query. Dim formattedStartDate As String Dim formattedEndDate As String Dim yourUserName As String Dim i, j, u As Integer Dim rs As ADODB.Recordset Dim sql As ADODB.Connection formattedStartDate = Month(Date) & "/" & Day(Date) - 7 & "/" & Year(Date) formattedEndDate = Month(Date) & "/" & Day(Date) & "/" & Year(Date) 'I realzie this is a security issue, and that I should not trust the users of the program but anyone who uses this program does not know how to open the vba editor, nor do they know VBA or SQL. It really is not a problem in my case. I promise! yourUserName = Application.userName 'Make sqlConnect the connection and rs the recordset. Set sqlConnect = New ADODB.Connection Set rs = New ADODB.Recordset 'Connect with the connectionstring. sqlConnect.connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\database.accdb;Persist Security Info=False;" 'Open connection string sqlConnect.Open 'Set rs.Activeconnection rs.ActiveConnection = sqlConnect rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato], [Sekundærstasjon], [Avgang], [Beskrivelse], [Til Dato] FROM [tblDatabase]" & _ "WHERE [Loggtype] = 'Beskjed' AND [Meldt Dato] >= DateAdd('d',-30,Date())" & _ "ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic 'Inserting data in first list j = 0 With ARK_front.lst_beskjeder .Clear Do While Not rs.EOF .AddItem If Not IsNull(rs!refnr) Then .List(j, 0) = rs![refnr] End If If IsDate(rs![Meldt Dato]) Then .List(j, 1) = Format(rs![Meldt Dato], "dd/mm/yy") End If .List(j, 4) = rs![nettstasjon] If Not IsNull(rs![Sekundærstasjon]) Then .List(j, 2) = rs![Sekundærstasjon] End If If Not IsNull(rs![Avgang]) Then .List(j, 3) = rs![Avgang] End If If Not IsNull(rs![beskrivelse]) Then .List(j, 5) = rs![beskrivelse] End If j = j + 1 rs.MoveNext Loop End With 'Close recordset and open a new one using the same connection as before rs.Close rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _ "WHERE [Registrert Av] <> '" & yourUserName & "' AND [Meldt Dato] BETWEEN #" & formattedStartDate & "# AND #" & formattedEndDate & "#" & _ "ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic 'Insert data into second list u = 0 With ARK_front.lst_AlleFeil .Clear Do While Not rs.EOF .AddItem If Not IsNull(rs!refnr) Then .List(u, 0) = rs![refnr] End If If IsDate(rs![Meldt Dato]) Then .List(u, 1) = Format(rs![Meldt Dato], "dd/mm/yy") End If If Not IsNull(rs![nettstasjon]) Then .List(u, 4) = rs![nettstasjon] End If If Not IsNull(rs![Sekundærstasjon]) Then .List(u, 2) = rs![Sekundærstasjon] End If If Not IsNull(rs![Avgang]) Then .List(u, 3) = rs![Avgang] End If If Not IsNull(rs![Hovedkomponent]) Then .List(u, 5) = rs![Hovedkomponent] End If If Not IsNull(rs![HovedÅrsak]) Then .List(u, 6) = rs![HovedÅrsak] End If If Not IsNull(rs![Status Bestilling]) Then .List(u, 7) = rs![Status Bestilling] End If If Not IsNull(rs![bestilling]) Then .List(u, 8) = rs![bestilling] End If u = u + 1 rs.MoveNext Loop End With 'Close recordset again, reopen. rs.Close rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _ "WHERE [Registrert Av] = '" & yourUserName & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & formattedStartDate & "# AND #" & formattedEndDate & "#" & _ "ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic 'Insert data into third list i = 0 With ARK_front.lst_mineFeil .Clear Do While Not rs.EOF .AddItem If Not IsNull(rs!refnr) Then .List(i, 0) = rs![refnr] End If If IsDate(rs![Meldt Dato]) Then .List(i, 1) = Format(rs![Meldt Dato], "dd/mm/yy") End If .List(i, 4) = rs![nettstasjon] If Not IsNull(rs![Sekundærstasjon]) Then .List(i, 2) = rs![Sekundærstasjon] End If If Not IsNull(rs![Avgang]) Then .List(i, 3) = rs![Avgang] End If If Not IsNull(rs![Hovedkomponent]) Then .List(i, 5) = rs![Hovedkomponent] End If If Not IsNull(rs![HovedÅrsak]) Then .List(i, 6) = rs![HovedÅrsak] End If If Not IsNull(rs![Status Bestilling]) Then .List(i, 7) = rs![Status Bestilling] End If If Not IsNull(rs![bestilling]) Then .List(i, 8) = rs![bestilling] End If i = i + 1 rs.MoveNext Loop End With 'Close recordset and close connection rs.Close sqlConnect.Close 'Set the recordset and the connection to nothing Set rs = Nothing Set sqlConnect = Nothing End Sub 

Hopefully this is now better. It doesnt seem so much faster, but it seems to be more stable. Any other tips would be fantastic :)

Thanks!

------ UPDATE ------

I am not sure what the correct way to do this is, but I have updated my code and will paste the new code.

My Worksheet Activate sub now looks like this:

Public Sub Worksheet_Activate() 'Removes shapes already there that will be updated by the getWeather function DeleteShapes 'Calls a function to get weather data from a web service. 'I tried not using the "Call" keyword, but that gives me an error message saying that I need to have this when calling a sub with more than one argument? Call GetWeather("url", "Area1") Call GetWeather("url", "Area2") Call GetWeather("url", "Area3") 'fill lists with information FillLists End Sub 

Here is the sub that deletes the shapes made by the last GetWeather update.

Public Sub DeleteShapes() Dim delShape As Shape For Each delShape In ARK_front.Shapes If delShape.Type = msoAutoShape Then delShape.Delete Next delShape End Sub 

Here is the GetWeather Sub

Public Sub GetWeather(APIurl As String, sted As String) Dim i As Integer Dim ws As Worksheet: Set ws = ActiveSheet Dim city, omraade As String Dim Req As New XMLHTTP Dim Weather As IXMLDOMNode Dim wShape As Shape Dim thisCell As Range Dim Resp As New DOMDocument i = 0 omraade = "" omraade = sted Select Case omraade Case "Area1" i = 4 Case "Area2" i = 6 Case "Area3" i = 8 Case Else Exit Sub End Select Req.Open "GET", "" & APIurl & "", False Req.Send Resp.LoadXML Req.responseText For Each Weather In Resp.getElementsByTagName("current_condition") Set thisCell = ws.Range(Cells(2, i), Cells(2, i)) Set wShape = ws.Shapes.AddShape(msoShapeRectangle, thisCell.Left, thisCell.Top, thisCell.Width, thisCell.Height) wShape.Fill.UserPicture Weather.ChildNodes(4).Text 'img Cells(3, i).Value = "" & Weather.ChildNodes(7).Text * 0.28 & " m/s" 'windspeedkmph Cells(4, i).Value = Weather.ChildNodes(9).Text 'Direction Cells(5, i).Value = Weather.ChildNodes(1).Text & " C" 'observation time Next Weather End Sub 

And here is the sub to fill the listboxes

Public Sub FillLists() 'I cannot run this sub with Option Explicit. It tells me I have a "Invalid inside procedure". And I cant for the life of me figure out what or where that is. 'Option Explicit ' I have to declare the formattedStartDate and formattedEndDate as String and not Date, because no matter what I try it forces the Date variable to format as dd/mm/yyyy even if I use format("","mm/dd/yyy"), which does not work with the access SQL query. Dim formattedStartDate As String Dim formattedEndDate As String Dim yourUserName As String Dim i, j, u As Integer Dim rs As ADODB.Recordset Dim sql As ADODB.Connection formattedStartDate = Month(Date) & "/" & Day(Date) - 7 & "/" & Year(Date) formattedEndDate = Month(Date) & "/" & Day(Date) & "/" & Year(Date) 'I realzie this is a security issue, and that I should not trust the users of the program but anyone who uses this program does not know how to open the vba editor, nor do they know VBA or SQL. It really is not a problem in my case. I promise! yourUserName = Application.userName 'Make sqlConnect the connection and rs the recordset. Set sqlConnect = New ADODB.Connection Set rs = New ADODB.Recordset 'Connect with the connectionstring. sqlConnect.connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\database.accdb;Persist Security Info=False;" 'Open connection string sqlConnect.Open 'Set rs.Activeconnection rs.ActiveConnection = sqlConnect rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato], [Sekundærstasjon], [Avgang], [Beskrivelse], [Til Dato] FROM [tblDatabase]" & _ "WHERE [Loggtype] = 'Beskjed' AND [Meldt Dato] >= DateAdd('d',-30,Date())" & _ "ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic 'Inserting data in first list j = 0 With ARK_front.lst_beskjeder .Clear Do While Not rs.EOF .AddItem If Not IsNull(rs!refnr) Then .List(j, 0) = rs![refnr] End If If IsDate(rs![Meldt Dato]) Then .List(j, 1) = Format(rs![Meldt Dato], "dd/mm/yy") End If .List(j, 4) = rs![nettstasjon] If Not IsNull(rs![Sekundærstasjon]) Then .List(j, 2) = rs![Sekundærstasjon] End If If Not IsNull(rs![Avgang]) Then .List(j, 3) = rs![Avgang] End If If Not IsNull(rs![beskrivelse]) Then .List(j, 5) = rs![beskrivelse] End If j = j + 1 rs.MoveNext Loop End With 'Close recordset and open a new one using the same connection as before rs.Close rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _ "WHERE [Registrert Av] <> '" & yourUserName & "' AND [Meldt Dato] BETWEEN #" & formattedStartDate & "# AND #" & formattedEndDate & "#" & _ "ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic 'Insert data into second list u = 0 With ARK_front.lst_AlleFeil .Clear Do While Not rs.EOF .AddItem If Not IsNull(rs!refnr) Then .List(u, 0) = rs![refnr] End If If IsDate(rs![Meldt Dato]) Then .List(u, 1) = Format(rs![Meldt Dato], "dd/mm/yy") End If If Not IsNull(rs![nettstasjon]) Then .List(u, 4) = rs![nettstasjon] End If If Not IsNull(rs![Sekundærstasjon]) Then .List(u, 2) = rs![Sekundærstasjon] End If If Not IsNull(rs![Avgang]) Then .List(u, 3) = rs![Avgang] End If If Not IsNull(rs![Hovedkomponent]) Then .List(u, 5) = rs![Hovedkomponent] End If If Not IsNull(rs![HovedÅrsak]) Then .List(u, 6) = rs![HovedÅrsak] End If If Not IsNull(rs![Status Bestilling]) Then .List(u, 7) = rs![Status Bestilling] End If If Not IsNull(rs![bestilling]) Then .List(u, 8) = rs![bestilling] End If u = u + 1 rs.MoveNext Loop End With 'Close recordset again, reopen. rs.Close rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _ "WHERE [Registrert Av] = '" & yourUserName & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & formattedStartDate & "# AND #" & formattedEndDate & "#" & _ "ORDER BY [Meldt Dato] DESC;", sqlConnect, adOpenStatic 'Insert data into third list i = 0 With ARK_front.lst_mineFeil .Clear Do While Not rs.EOF .AddItem If Not IsNull(rs!refnr) Then .List(i, 0) = rs![refnr] End If If IsDate(rs![Meldt Dato]) Then .List(i, 1) = Format(rs![Meldt Dato], "dd/mm/yy") End If .List(i, 4) = rs![nettstasjon] If Not IsNull(rs![Sekundærstasjon]) Then .List(i, 2) = rs![Sekundærstasjon] End If If Not IsNull(rs![Avgang]) Then .List(i, 3) = rs![Avgang] End If If Not IsNull(rs![Hovedkomponent]) Then .List(i, 5) = rs![Hovedkomponent] End If If Not IsNull(rs![HovedÅrsak]) Then .List(i, 6) = rs![HovedÅrsak] End If If Not IsNull(rs![Status Bestilling]) Then .List(i, 7) = rs![Status Bestilling] End If If Not IsNull(rs![bestilling]) Then .List(i, 8) = rs![bestilling] End If i = i + 1 rs.MoveNext Loop End With 'Close recordset and close connection rs.Close sqlConnect.Close 'Set the recordset and the connection to nothing Set rs = Nothing Set sqlConnect = Nothing End Sub 

Hopefully this is now better. It doesnt seem so much faster, but it seems to be more stable. Any other tips would be fantastic :)

Thanks!

Private Sub Worksheet_Activate() Application.ScreenUpdating = False 'Removes shapes already there that will be updated by the getWeather function For Each delShape In Shapes If delShape.Type = msoAutoShape Then delShape.Delete Next delShape 'Calls a function to get weather data from a web service Call getWeather("", "Area1") Call getWeather("", "Area2") Call getWeather("", "Area3") 'Starting to implement the first connection to a SQL Access database. Dim cn As Object Dim rs As Object 'Set cn and sqlConnect as ADODB-objects. Set rs as recordset Set cn = CreateObject("ADODB.Connection") Set sqlConnect = New ADODB.Connection Set rs = CreateObject("ADODB.RecordSet") 'Set sqlConnect as connection string sqlConnect.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;" 'Open connection string via connection object cn.Open sqlConnect 'Set rs.Activeconnection to cn rs.ActiveConnection = cn 'Get a username from the application to be used further down Brukernavn = Application.userName 'This part of the code re-arranges the date format from american to european StartDate = Date EndDate = Date - 7 midStartDate = Split(StartDate, ".") midEndDate = Split(EndDate, ".") StartDate2 = "" & midStartDate(1) & "/" & midStartDate(0) & "/" & midStartDate(2) & "" EndDate2 = "" & midEndDate(1) & "/" & midEndDate(0) & "/" & midEndDate(2) & "" 'SQL statement to get data from the access database rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _ "WHERE [Registrert Av] = '" & Brukernavn & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _ "ORDER BY [Meldt Dato] DESC;", _ cn, adOpenStatic 'Start to insert data from access database into a list Dim i As Integer Dim u As Integer If Not rs.EOF Then rs.MoveFirst End If i = 0 With lst_SisteFeil .Clear Do If Not rs.EOF Then .AddItem If Not IsNull(rs!refnr) Then .List(i, 0) = rs![refnr] End If If IsDate(rs![Meldt Dato]) Then .List(i, 1) = Format(rs![Meldt Dato], "dd/mm/yy") End If .List(i, 4) = rs![nettstasjon] If Not IsNull(rs![Sekundærstasjon]) Then .List(i, 2) = rs![Sekundærstasjon] End If If Not IsNull(rs![Avgang]) Then .List(i, 3) = rs![Avgang] End If If Not IsNull(rs![Hovedkomponent]) Then .List(i, 5) = rs![Hovedkomponent] End If If Not IsNull(rs![HovedÅrsak]) Then .List(i, 6) = rs![HovedÅrsak] End If If Not IsNull(rs![Status Bestilling]) Then .List(i, 7) = rs![Status Bestilling] End If If Not IsNull(rs![bestilling]) Then .List(i, 8) = rs![bestilling] End If i = i + 1 rs.MoveNext Else GoTo endOfFile End If Loop Until rs.EOF End With endOfFile: rs.Close cn.Close Set rs = Nothing Set cn = Nothing 'Starts to connect to SQL access database again to get different set of data. This must be possible to make more efficient? Dim cn2 As Object Dim rs2 As Object 'Set cn and sqlConnect as ADODB-objects. Set rs as recordset Set cn2 = CreateObject("ADODB.Connection") Set sqlConnect2 = New ADODB.Connection Set rs2 = CreateObject("ADODB.RecordSet") 'Set sqlConnect as connection string sqlConnect2.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;" 'Open connection string via connection object cn2.Open sqlConnect 'Set rs.Activeconnection to cn rs2.ActiveConnection = cn2 'Second SQL statement rs2.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _ "WHERE [Registrert Av] <> '" & Brukernavn & "' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _ "ORDER BY [Meldt Dato] DESC;", _ cn2, adOpenStatic 'Inserting into second list If Not rs2.EOF Then rs2.MoveFirst End If u = 0 With lst_AlleFeil .Clear Do If Not rs2.EOF Then .AddItem If Not IsNull(rs2!refnr) Then .List(u, 0) = rs2![refnr] End If If IsDate(rs2![Meldt Dato]) Then .List(u, 1) = Format(rs2![Meldt Dato], "dd/mm/yy") End If .List(u, 4) = rs2![nettstasjon] If Not IsNull(rs2![Sekundærstasjon]) Then .List(u, 2) = rs2![Sekundærstasjon] End If If Not IsNull(rs2![Avgang]) Then .List(u, 3) = rs2![Avgang] End If If Not IsNull(rs2![Hovedkomponent]) Then .List(u, 5) = rs2![Hovedkomponent] End If If Not IsNull(rs2![HovedÅrsak]) Then .List(u, 6) = rs2![HovedÅrsak] End If If Not IsNull(rs2![Status Bestilling]) Then .List(u, 7) = rs2![Status Bestilling] End If If Not IsNull(rs2![bestilling]) Then .List(u, 8) = rs2![bestilling] End If u = u + 1 rs2.MoveNext Else GoTo endOfFile2 End If Loop Until rs2.EOF End With endOfFile2: rs2.Close cn2.Close Set rs2 = Nothing Set cn2 = Nothing 'Starting to connect to the database for the third time Dim cn3 As Object Dim rs3 As Object 'Set cn and sqlConnect as ADODB-objects. Set rs as recordset Set cn3 = CreateObject("ADODB.Connection") Set sqlConnect3 = New ADODB.Connection Set rs3 = CreateObject("ADODB.RecordSet") 'Set sqlConnect as connection string sqlConnect3.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\databases\database.accdb;Persist Security Info=False;" 'Open connection string via connection object cn3.Open sqlConnect 'Set rs.Activeconnection to cn rs3.ActiveConnection = cn3 'third sql statement rs3.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato], [Sekundærstasjon], [Avgang], [Beskrivelse], [Til Dato] FROM [tblDatabase]" & _ "WHERE [Loggtype] = 'Beskjed' AND [Meldt Dato] >= DateAdd('d',-30,Date())" & _ "ORDER BY [Meldt Dato] DESC;", _ cn3, adOpenStatic 'Inserting data in to third list If Not rs3.EOF Then rs3.MoveFirst End If j = 0 With lst_beskjeder .Clear Do If Not rs3.EOF Then .AddItem If Not IsNull(rs3!refnr) Then .List(j, 0) = rs3![refnr] End If If IsDate(rs3![Meldt Dato]) Then .List(j, 1) = Format(rs3![Meldt Dato], "dd/mm/yy") End If .List(j, 4) = rs3![nettstasjon] If Not IsNull(rs3![Sekundærstasjon]) Then .List(j, 2) = rs3![Sekundærstasjon] End If If Not IsNull(rs3![Avgang]) Then .List(j, 3) = rs3![Avgang] End If If Not IsNull(rs3![beskrivelse]) Then .List(j, 5) = rs3![beskrivelse] End If j = j + 1 rs3.MoveNext Else GoTo endOfFile3 End If Loop Until rs3.EOF End With endOfFile3: rs3.Close cn3.Close Set rs3 = Nothing Set cn3 = Nothing End Sub 

Private Sub Worksheet_Activate() Application.ScreenUpdating = False 'Removes shapes already there that will be updated by the getWeather function For Each delShape In Shapes If delShape.Type = msoAutoShape Then delShape.Delete Next delShape 'Calls a function to get weather data from a web service Call getWeather("", "Area1") Call getWeather("", "Area2") Call getWeather("", "Area3") 'Starting to implement the first connection to a SQL Access database. Dim cn As Object Dim rs As Object 'Set cn and sqlConnect as ADODB-objects. Set rs as recordset Set cn = CreateObject("ADODB.Connection") Set sqlConnect = New ADODB.Connection Set rs = CreateObject("ADODB.RecordSet") 'Set sqlConnect as connection string sqlConnect.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;" 'Open connection string via connection object cn.Open sqlConnect 'Set rs.Activeconnection to cn rs.ActiveConnection = cn 'Get a username from the application to be used further down Brukernavn = Application.userName 'This part of the code re-arranges the date format from american to european StartDate = Date EndDate = Date - 7 midStartDate = Split(StartDate, ".") midEndDate = Split(EndDate, ".") StartDate2 = "" & midStartDate(1) & "/" & midStartDate(0) & "/" & midStartDate(2) & "" EndDate2 = "" & midEndDate(1) & "/" & midEndDate(0) & "/" & midEndDate(2) & "" 'SQL statement to get data from the access database rs.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _ "WHERE [Registrert Av] = '" & Brukernavn & "' AND [Loggtype] <> 'Beskjed' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _ "ORDER BY [Meldt Dato] DESC;", _ cn, adOpenStatic 'Start to insert data from access database into a list Dim i As Integer Dim u As Integer If Not rs.EOF Then rs.MoveFirst End If i = 0 With lst_SisteFeil .Clear Do If Not rs.EOF Then .AddItem If Not IsNull(rs!refnr) Then .List(i, 0) = rs![refnr] End If If IsDate(rs![Meldt Dato]) Then .List(i, 1) = Format(rs![Meldt Dato], "dd/mm/yy") End If .List(i, 4) = rs![nettstasjon] If Not IsNull(rs![Sekundærstasjon]) Then .List(i, 2) = rs![Sekundærstasjon] End If If Not IsNull(rs![Avgang]) Then .List(i, 3) = rs![Avgang] End If If Not IsNull(rs![Hovedkomponent]) Then .List(i, 5) = rs![Hovedkomponent] End If If Not IsNull(rs![HovedÅrsak]) Then .List(i, 6) = rs![HovedÅrsak] End If If Not IsNull(rs![Status Bestilling]) Then .List(i, 7) = rs![Status Bestilling] End If If Not IsNull(rs![bestilling]) Then .List(i, 8) = rs![bestilling] End If i = i + 1 rs.MoveNext Else GoTo endOfFile End If Loop Until rs.EOF End With endOfFile: rs.Close cn.Close Set rs = Nothing Set cn = Nothing 'Starts to connect to SQL access database again to get different set of data. This must be possible to make more efficient? Dim cn2 As Object Dim rs2 As Object 'Set cn and sqlConnect as ADODB-objects. Set rs as recordset Set cn2 = CreateObject("ADODB.Connection") Set sqlConnect2 = New ADODB.Connection Set rs2 = CreateObject("ADODB.RecordSet") 'Set sqlConnect as connection string sqlConnect2.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\databases\database.accdb;Persist Security Info=False;" 'Open connection string via connection object cn2.Open sqlConnect 'Set rs.Activeconnection to cn rs2.ActiveConnection = cn2 'Second SQL statement rs2.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato] , [Bestilling], [Sekundærstasjon], [Avgang], [Hovedkomponent], [HovedÅrsak], [Status Bestilling] FROM [tblDatabase]" & _ "WHERE [Registrert Av] <> '" & Brukernavn & "' AND [Meldt Dato] BETWEEN #" & StartDate2 & "# AND # " & EndDate2 & "#" & _ "ORDER BY [Meldt Dato] DESC;", _ cn2, adOpenStatic 'Inserting into second list If Not rs2.EOF Then rs2.MoveFirst End If u = 0 With lst_AlleFeil .Clear Do If Not rs2.EOF Then .AddItem If Not IsNull(rs2!refnr) Then .List(u, 0) = rs2![refnr] End If If IsDate(rs2![Meldt Dato]) Then .List(u, 1) = Format(rs2![Meldt Dato], "dd/mm/yy") End If .List(u, 4) = rs2![nettstasjon] If Not IsNull(rs2![Sekundærstasjon]) Then .List(u, 2) = rs2![Sekundærstasjon] End If If Not IsNull(rs2![Avgang]) Then .List(u, 3) = rs2![Avgang] End If If Not IsNull(rs2![Hovedkomponent]) Then .List(u, 5) = rs2![Hovedkomponent] End If If Not IsNull(rs2![HovedÅrsak]) Then .List(u, 6) = rs2![HovedÅrsak] End If If Not IsNull(rs2![Status Bestilling]) Then .List(u, 7) = rs2![Status Bestilling] End If If Not IsNull(rs2![bestilling]) Then .List(u, 8) = rs2![bestilling] End If u = u + 1 rs2.MoveNext Else GoTo endOfFile2 End If Loop Until rs2.EOF End With endOfFile2: rs2.Close cn2.Close Set rs2 = Nothing Set cn2 = Nothing 'Starting to connect to the database for the third time Dim cn3 As Object Dim rs3 As Object 'Set cn and sqlConnect as ADODB-objects. Set rs as recordset Set cn3 = CreateObject("ADODB.Connection") Set sqlConnect3 = New ADODB.Connection Set rs3 = CreateObject("ADODB.RecordSet") 'Set sqlConnect as connection string sqlConnect3.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\databases\database.accdb;Persist Security Info=False;" 'Open connection string via connection object cn3.Open sqlConnect 'Set rs.Activeconnection to cn rs3.ActiveConnection = cn3 'third sql statement rs3.Open "SELECT [RefNr], [Registrert Av],[Nettstasjon], [Meldt Dato], [Sekundærstasjon], [Avgang], [Beskrivelse], [Til Dato] FROM [tblDatabase]" & _ "WHERE [Loggtype] = 'Beskjed' AND [Meldt Dato] >= DateAdd('d',-30,Date())" & _ "ORDER BY [Meldt Dato] DESC;", _ cn3, adOpenStatic 'Inserting data in to third list If Not rs3.EOF Then rs3.MoveFirst End If j = 0 With lst_beskjeder .Clear Do If Not rs3.EOF Then .AddItem If Not IsNull(rs3!refnr) Then .List(j, 0) = rs3![refnr] End If If IsDate(rs3![Meldt Dato]) Then .List(j, 1) = Format(rs3![Meldt Dato], "dd/mm/yy") End If .List(j, 4) = rs3![nettstasjon] If Not IsNull(rs3![Sekundærstasjon]) Then .List(j, 2) = rs3![Sekundærstasjon] End If If Not IsNull(rs3![Avgang]) Then .List(j, 3) = rs3![Avgang] End If If Not IsNull(rs3![beskrivelse]) Then .List(j, 5) = rs3![beskrivelse] End If j = j + 1 rs3.MoveNext Else GoTo endOfFile3 End If Loop Until rs3.EOF End With endOfFile3: rs3.Close cn3.Close Set rs3 = Nothing Set cn3 = Nothing End Sub 

Public Sub getWeather(APIurl As String, sted As String) Dim i As Integer i = 0 Dim omraade As String omraade = "" omraade = sted If sted = "Area1" Then i = 4 ElseIf sted = "Area2" Then i = 6 ElseIf sted = "Area3" Then i = 8 End If Dim WS As Worksheet: Set WS = ActiveSheet Dim delShape As Shape Dim city As String Dim Req As New XMLHTTP Req.Open "GET", "" & APIurl & "", False Req.Send Dim Resp As New DOMDocument Resp.LoadXML Req.responseText Dim Weather As IXMLDOMNode Dim wShape As Shape Dim thisCell As Range For Each Weather In Resp.getElementsByTagName("current_condition") Set thisCell = WS.Range(Cells(2, i), Cells(2, i)) Set wShape = WS.Shapes.AddShape(msoShapeRectangle, thisCell.Left, thisCell.Top, thisCell.Width, thisCell.Height) wShape.Fill.UserPicture Weather.ChildNodes(4).Text 'img Cells(3, i).Value = "" & Weather.ChildNodes(7).Text * 0.28 & " m/s" 'windspeedkmph Cells(4, i).Value = Weather.ChildNodes(9).Text 'Direction Cells(5, i).Value = Weather.ChildNodes(1).Text & " C" 'observation time Next Weather End Sub 

Public Sub getWeather(APIurl As String, sted As String) Dim i As Integer i = 0 Dim omraade As String omraade = "" omraade = sted If sted = "Area1" Then i = 4 ElseIf sted = "Area2" Then i = 6 ElseIf sted = "Area3" Then i = 8 End If Dim WS As Worksheet: Set WS = ActiveSheet Dim delShape As Shape Dim city As String Dim Req As New XMLHTTP Req.Open "GET", "" & APIurl & "", False Req.Send Dim Resp As New DOMDocument Resp.LoadXML Req.responseText Dim Weather As IXMLDOMNode Dim wShape As Shape Dim thisCell As Range For Each Weather In Resp.getElementsByTagName("current_condition") Set thisCell = WS.Range(Cells(2, i), Cells(2, i)) Set wShape = WS.Shapes.AddShape(msoShapeRectangle, thisCell.Left, thisCell.Top, thisCell.Width, thisCell.Height) wShape.Fill.UserPicture Weather.ChildNodes(4).Text 'img Cells(3, i).Value = "" & Weather.ChildNodes(7).Text * 0.28 & " m/s" 'windspeedkmph Cells(4, i).Value = Weather.ChildNodes(9).Text 'Direction Cells(5, i).Value = Weather.ChildNodes(1).Text & " C" 'observation time Next Weather End Sub