Loop through list, perform web query and save each query on its own page

I have the following code that does MOST of what I need it to do except it does not save each query on its own worksheet!

The code runs each query from the list but it saves them side by side in one worksheet

Using Excel 2010 and Win7 Pro
Any help appreciated.

Option Explicit

Sub Refresh()
Dim cl As Range, sht As Worksheet, rng As Range
Dim strName As String
Set rng = Worksheets("Dog").Range("A1")
Application.ScreenUpdating = False
For Each cl In rng
If Trim(cl.Value) <> "" Then
strName = cl.Value
Application.DisplayAlerts = False
On Error Resume Next
Set sht = Worksheets(strName)
sht.Delete
ThisWorkbook.Worksheets.Add
ActiveSheet.Name = strName
Application.DisplayAlerts = True
On Error GoTo 0
Sheets(strName).Activate
ActiveSheet.Range("A1") = strName

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;https:WEBSITE=" & strName
Destination:=Range("A1"))
.Name = "ALL&DOG=" & strName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End If
Next cl
Worksheets("Dog").Activate
End Sub