Issues with Macro to import data from web, create pivot table & filter it based on a dynamic range

[Anikipipo]

Hi All,

I'm a newbie with VB & macros, i've been recording a macro manually and tried to edit it with bits and pieces that i found on several forums.
It does work to a certain extent but i'm hitting several issues.

i have a workbook with 3 sheets "NECA ASR Pivot Table", "Install Compliance NECA" & "Values".

The idea is to import a weekly report that i get from an internal website in "Install Compliance NECA" sheet, create a pivot table in "NECA ASR Pivot Table" sheet, filter it based on a dynamic range with names on the "Values" sheet and add the last updated date from another internal link (i use the same import data from web feature) in a cell from the "NECA ASR Pivot Table" sheet.

The refresh button is located on the "NECA ASR Pivot Table" sheet and the macro is recorded so that everytime i hit the button it deletes the pivot table & the content in "Install Compliance NECA" sheet then import again and recreate the pivot table from scratch.

I'm having issues deleting the pivot table (not sure my code works) and adding a count datafield (application-defined or object-defined error on this line below which seems to work if i change the caption "Count of TLA Serial Number" but then add a 2nd column on the right side of the pivot table).

Worksheets("NECA ASR Pivot Table").PivotTables(1).AddDataField Worksheets("NECA ASR Pivot Table").PivotTables(1).PivotFields("TLA Serial Number"), "Count of TLA Serial Number", _
xlCount

Also my filtering part of the code at the bottom used to work as a single function in the workbook but when i incorporated it to the macro it stopped filtering.

I also realize that all this doesn't look like a very clean and efficient code...

Here's the code:
==============


' Delete all pivot tables
Option Explicit


Sub DeleteAllPivotTablesInWorkbook()
Dim WB As Workbook, WS As Worksheet, PT As PivotTable
If ActiveWorkbook Is Nothing Then
MsgBox "There is no active workbook!", vbExclamation, "ERROR!"
Exit Sub
End If
If MsgBox("Delete ALL pivot tables in the active workbook?", _
vbYesNo + vbDefaultButton2, "DELETE ALL?") = vbNo Then Exit Sub
On Error Resume Next
For Each WS In ActiveWorkbook.Worksheets
For Each PT In WS.PivotTables
WS.Range(PT.TableRange2.Address).Delete Shift:=xlUp
Next PT
Next WS
End Sub


Sub Refresh()
'
' Refresh Macro
'


Sheets("Install Compliance NECA").Select
Cells.Select
Range("A8").Activate
Selection.Delete Shift:=xlUp
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://opsconsole/installCompliance/detail.php?geo=Northeast/Canada%20CS%20Division&family=Total&ic=0" _
, Destination:=Range("$A$1"))
'.CommandType = 0
.Name = "NECA_Install_Compliance"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("A15").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
ActiveWorkbook.Save

Dim Addr As String
Dim Sh As Worksheet
With ActiveSheet
Addr = Worksheets("Install Compliance NECA").Range("A9").CurrentRegion.Address(True, True, xlR1C1)
End With
'Set Sh = Worksheets.Add
'Sh.Name = "NECA ASR Pivot Table"
Sheets("Install Compliance NECA").Select
'ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
Addr, Version:=xlPivotTableVersionCurrent).CreatePivotTable _
TableDestination:="NECA ASR Pivot Table!R5C1", DefaultVersion _
:=xlPivotTableVersionCurrent
Cells(5, 1).Select
ActiveWorkbook.ShowPivotTableFieldList = True
With Worksheets("NECA ASR Pivot Table").PivotTables(1).PivotFields("Region")
.Orientation = xlPageField
.Position = 1
End With
With Worksheets("NECA ASR Pivot Table").PivotTables(1).PivotFields("District")
.Orientation = xlPageField
.Position = 1
End With
With Worksheets("NECA ASR Pivot Table").PivotTables(1).PivotFields("ASR Name")
.Orientation = xlRowField
.Position = 1
End With
With Worksheets("NECA ASR Pivot Table").PivotTables(1).PivotFields("CS Site Name")
.Orientation = xlRowField
.Position = 2
End With
With Worksheets("NECA ASR Pivot Table").PivotTables(1).PivotFields("TLA Serial Number")
.Orientation = xlRowField
.Position = 2
End With
Worksheets("NECA ASR Pivot Table").PivotTables(1).AddDataField Worksheets("NECA ASR Pivot Table").PivotTables(1).PivotFields("TLA Serial Number"), "Count of TLA Serial Number", _
xlCount

Sheets("Values").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://opsconsole.corp.emc.com/installCompliance/ocSumTable.php?geo=Northeast/Canada%20CS%20Division" _
, Destination:=Range("$H$6"))
'.CommandType = 0
.Name = "Last_Update_Date"
.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
Selection.ClearContents
Range("H8").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("H7").Select
Selection.Cut
Range("C6").Select
ActiveSheet.Paste
Range("H7").Select
Selection.ClearContents
Range("H6").Select
Selection.ClearContents
Sheets("NECA ASR Pivot Table").Select

End Sub


Private Function Filter_PivotField(pvtField As PivotField, _
varItemList As Variant)
Dim strItem1 As String
Dim i As Long
On Error GoTo ErrorHandler:
Application.ScreenUpdating = False

strItem1 = varItemList(LBound(varItemList))
With pvtField
.PivotItems(strItem1).Visible = True
For i = 1 To .PivotItems.Count
If .PivotItems(i) <> strItem1 And _
.PivotItems(i).Visible = True Then
.PivotItems(i).Visible = False
End If
Next i
For i = LBound(varItemList) + 1 To UBound(varItemList)
.PivotItems(varItemList(i)).Visible = True
Next i
End With
Exit Function
ErrorHandler:
MsgBox "Error while trying to process item: " & varItemList(i)
End Function
Sub Filter_ItemListInRange()
Filter_PivotField _
pvtField:=Sheets("NECA ASR Pivot Table").PivotTables(1).PivotFields("ASR Name"), _
varItemList:=Application.Transpose(Sheets("Values").Range("NECA_ASR"))
ActiveWorkbook.Save
End Sub
==============


Thx in advance for your help.

 

[Anikipipo]

I have worked out most of the issues in the meantime, i will post the outcome when done with testing.

 

[thatmarine]

Anikipipo,

Would you mind posting your code? I have a similar problem that I am trying to solve. Thanks

 

[Anikipipo]

I ended up making quite a few changes but here it is.

======================
Sub Refresh()

Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("DB").Delete
On Error GoTo 0
Application.DisplayAlerts = True
ThisWorkbook.Sheets.Add.Name = "DB"
ActiveWorkbook.Sheets("DB").Move After:=ActiveWorkbook.Sheets("Sheet2")
ActiveWorkbook.Save
Sheets("DB").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" _
, Destination:=Range("$A$1"))
'.CommandType = 0
.Name = "ABC"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("A8").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
ActiveWorkbook.Save
Call DeleteBadRefs
Call DynamicRange
Call RefreshingPivotTables
Call Filter_ItemListInRange
Call Last_Update_Date

End Sub


Sub DeleteBadRefs()
Dim nm As Name

For Each nm In ActiveWorkbook.Names
If InStr(1, nm.RefersTo, "#REF!") > 0 Then
'List the name before deleting
Debug.Print nm.Name & ": deleted"
nm.Delete
End If
Next nm
End Sub


Sub DynamicRange()

ActiveWorkbook.Names.Add Name:="Sheet1", RefersToR1C1:= _
"=OFFSET('DB'!R8C1,0,0,COUNTA('DB'!C17)-1,59)"
ActiveWorkbook.Names("Sheet1").Comment = ""


End Sub


Sub RefreshingPivotTables()


Dim pt As PivotTable
Set pt = Worksheets("Sheet2").PivotTables("PT1")


pt.RefreshTable

Sheets("Sheet2").Select
ActiveSheet.PivotTables("PT1").PivotFields("ASR Name").ClearAllFilters


ActiveWorkbook.Save

End Sub

Private Function Filter_PivotField(pvtField As PivotField, varItemList As Variant)
Dim strItem1 As String
Dim i As Long
On Error GoTo ErrorHandler:
Application.ScreenUpdating = False

strItem1 = varItemList(LBound(varItemList))
With pvtField
.PivotItems(strItem1).Visible = True
For i = 1 To .PivotItems.Count
If .PivotItems(i) <> strItem1 And _
.PivotItems(i).Visible = True Then
.PivotItems(i).Visible = False
End If
Next i
For i = LBound(varItemList) + 1 To UBound(varItemList)
.PivotItems(varItemList(i)).Visible = True
Next i
End With
Exit Function
ErrorHandler:
MsgBox "Error while trying to process item: " & varItemList(i)
End Function


Sub Filter_ItemListInRange()
Filter_PivotField _
pvtField:=Sheets("Sheet2").PivotTables(1).PivotFields("ASR Name"), _
varItemList:=Application.Transpose(Sheets("Sheet2").Range("PT1"))
ActiveWorkbook.ShowPivotTableFieldList = False
ActiveWorkbook.Save
End Sub


Sub Last_Update_Date()


Sheets("Values").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" _
, Destination:=Range("$H$6"))
'.CommandType = 0
.Name = "Last_Update_Date"
.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
Selection.ClearContents
Range("H8").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("H7").Select
Selection.Copy
Range("A6").Select
ActiveSheet.Paste
Range("H7").Select
Selection.ClearContents
Range("H6").Select
Selection.ClearContents
'ActiveWorkbook.Names("Last_Update_Date").Delete
Sheets("Sheet2").Select
ActiveWorkbook.Save
End Sub
======================

 

[thatmarine]

thanks man.