Private Sub UserForm_Initialize()
Dim BB As String
On Error Resume Next
Application.ScreenUpdating = False
Workbooks.Add
BB = ActiveWorkbook.Name
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Web Query"
'-----------------------------------------------------------------------------------
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://portal.scg.com/company/hitechmold/Lists/Phone%20List/Tennessee%20Phone%20List.aspx" _
, Destination:=Range("$A$1"))
.Name = "Tennessee%20Phone%20List"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = _
"8,""{728E1EC5-4C6F-4713-9468-70BB90B06FCB}-{B375D5F9-2E4A-4D65-9633-B558E79C9CF1}"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Rows("2:7").Select
Selection.Delete Shift:=xlUp
Columns(3).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'-----------------------------------------------------------------------------------
LastRow = Range("B" & Rows.Count).End(xlUp).Row
LastRow.Activate
With ListBox1
.ColumnCount = 4
.ColumnWidths = "80;80;80;80" 'points
.BoundColumn = 1 'if it's bound to a cell, column 2 is returned
.ControlSource = "Web Query!A1"
.RowSource = "B1:E1" & LastRow 'The array of cells that provide values
End With
Workbooks(BB).Saved = True
Workbooks(BB).Close
Application.ScreenUpdating = True
End Sub