[RESOLVED] Excel - pivot table - vba

Found a post for help on linkedin - thought it would be good to remember how to actually do stuff in vba (not used it for 3 years).

The general request was to open two passworded excel files using vba, combine the data and pivot it. Fairly simple. ish
I managed to make two excel books passworded with a simple two columns of data.
Got it to combine.
And fell flat on my face with the pivot table in vba. Did MS mess it up or am I doing it wrong (obviously the latter but where)?
Code is below, commented out the pivot part I'm stuck with.

Code:

---

Option Explicit

Public Sub CombineData()
    Dim xl As Excel.Application
    Dim wrk As Workbook
    Dim wrkS As Workbook
    Dim sht As Worksheet
    Dim shtS As Worksheet
    Dim shtP As Worksheet
    Dim rng As Range
   
    Dim pvt As PivotTable
    Dim pf As PivotField
    Dim pfd As PivotField
   
    Dim strFp As String
    Dim lngRowOP As Long
    Dim lngMaxRows As Long
    Dim lngCurRow As Long
    Dim bHasTitle As Boolean
   
   
    Set xl = Application
    Set wrk = ActiveWorkbook
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
'---- check if there is a combined sheet already - get rid of it if there is
    On Error Resume Next
    If wrk.Sheets("combined").Name = "combined" Then wrk.Sheets("combined").Delete
    If wrk.Sheets("pivot").Name = "pivot" Then wrk.Sheets("pivot").Delete
    On Error GoTo 0
    Set sht = wrk.Sheets.Add
    sht.Name = "combined"
   
'---- change to loop a selection of file(s) here
    strFp = wrk.Path & "\" & "data*.xlsx"
    lngRowOP = 2
    sht.Cells(1, 1) = "column 1"
    sht.Cells(1, 2) = "column 2"
   
    strFp = Dir(strFp, 63)
    Do While strFp <> ""
        Set wrkS = xl.Workbooks.Open(strFp, , True, , "test")
        Set shtS = wrkS.Sheets(1) 'or use the name if the name is the same
        bHasTitle = True 'ignore first line
   
        lngMaxRows = shtS.Cells(65535, 1).End(xlUp).Row
    '    For lngCurRow = 2 To lngMaxRows
    '        sht.Cells(lngRowOP, 1) = shtS.Cells(lngCurRow, 1)
    '        sht.Cells(lngRowOP, 2) = shtS.Cells(lngCurRow, 2)
    '        lngRowOP = lngRowOP + 1
    '    Next
'---- or
        Set rng = shtS.Range(shtS.Cells(2, 1), shtS.Cells(lngMaxRows, 2))
        rng.Copy
        sht.Cells(lngRowOP, 1).PasteSpecial xlPasteValues
        lngRowOP = lngRowOP + lngMaxRows - IIf(bHasTitle, 1, 0)
   
        wrkS.Close
        strFp = Dir
    Loop
'---- to here ... loop
   
    'do duplicates checks here - if required
   
    'make a pivot table of the data
    Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(lngRowOP - 1, 2))
    Set shtP = wrk.Worksheets.Add
    shtP.Name = "pivot"
    Set pvt = wrk.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rng, Version:=6).CreatePivotTable(TableDestination:=shtP.Cells(3, 1), TableName:="CombinedPvT", DefaultVersion:=6)
    With pvt
        .ColumnGrand = False
        .NullString = "0"
    End With
    With pvt.PivotFields("column 1")
        .Orientation = xlRowField
        .Position = 1
    End With
    Set pf = pvt.PivotFields("column 2")
    With pf
        .Orientation = xlColumnField
        .Position = 1
    End With
   
   
    'Set pfd = pvt.AddDataField(pvt.PivotFields("column 2"), pvt.PivotFields("count of column 2"), xlSum)
    'With pfd
    '    .Caption = "Count"
    '    .Function = xlCount
    'End With
    'With pvt.PivotFields("sum of column 2")
    '    .Caption = "Count"
    '    .Function = xlCount
    'End With
   

    shtP.Cells(1, 1).Select
    sht.Select
    sht.Cells(1, 1).Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
       
    Set shtS = Nothing
    Set sht = Nothing
    Set wrk = Nothing
   
   
End Sub

---

Problem is when I create the data field it removes the column when it shouldn't.

any pointers or is it just vba pivot is more messy than I remember ?
(the base code I recorded a macro, just changed to objects)

there was a thread recently that i contributed to, to create a pivot table using vba, after several attempts got it sort of working, though not completely as required, at that point i got busy with some other stuff of my own, so did not look at it further

as i have never really worked with pivot tables i was just working with trial and error, not really knowing what final result was expected, and some stuff not working as i expected

anyway the thread is http://www.vbforums.com/showthread.p...heet-using-VBA

Thanks

That did help.

Code:

---

Option Explicit

Public Sub CombineData()
    Dim xl As Excel.Application
    Dim wrk As Workbook
    Dim wrkS As Workbook
    Dim sht As Worksheet
    Dim shtS As Worksheet
    Dim shtP As Worksheet
    Dim rng As Range
   
    Dim pvt As PivotTable
    Dim pf As PivotField
    Dim pfd As PivotField
   
    Dim strFp As String
    Dim lngRowOP As Long
    Dim lngMaxRows As Long
    Dim lngCurRow As Long
    Dim bHasTitle As Boolean
   
   
    Set xl = Application
    Set wrk = ActiveWorkbook
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
'---- check if there is a combined sheet already - get rid of it if there is
    On Error Resume Next
    If wrk.Sheets("combined").Name = "combined" Then wrk.Sheets("combined").Delete
    If wrk.Sheets("pivot").Name = "pivot" Then wrk.Sheets("pivot").Delete
    On Error GoTo 0
    Set sht = wrk.Sheets.Add
    sht.Name = "combined"
   
'---- change to loop a selection of file(s) here
    strFp = wrk.Path & "\" & "data*.xlsx"
    lngRowOP = 2
    sht.Cells(1, 1) = "column 1"
    sht.Cells(1, 2) = "column 2"
   
    strFp = Dir(strFp, 63)
    Do While strFp <> ""
        Set wrkS = xl.Workbooks.Open(strFp, , True, , "test")
        Set shtS = wrkS.Sheets(1) 'or use the name if the name is the same
        bHasTitle = True 'ignore first line
   
        lngMaxRows = shtS.Cells(65535, 1).End(xlUp).Row
    '    For lngCurRow = 2 To lngMaxRows
    '        sht.Cells(lngRowOP, 1) = shtS.Cells(lngCurRow, 1)
    '        sht.Cells(lngRowOP, 2) = shtS.Cells(lngCurRow, 2)
    '        lngRowOP = lngRowOP + 1
    '    Next
'---- or
        Set rng = shtS.Range(shtS.Cells(2, 1), shtS.Cells(lngMaxRows, 2))
        rng.Copy
        sht.Cells(lngRowOP, 1).PasteSpecial xlPasteValues
        lngRowOP = lngRowOP + lngMaxRows - IIf(bHasTitle, 1, 0)
   
        wrkS.Close
        strFp = Dir
    Loop
'---- to here ... loop
   
    'do duplicates checks here - if required
   
    'make a pivot table of the data
    Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(lngRowOP - 1, 2))
    Set shtP = wrk.Worksheets.Add
    shtP.Name = "pivot"
    Set pvt = wrk.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rng, Version:=6).CreatePivotTable(TableDestination:=shtP.Cells(3, 1), TableName:="CombinedPvT", DefaultVersion:=6)
    With pvt
        .ColumnGrand = False
        .NullString = "0"
    End With
    With pvt.PivotFields("column 1")
        .Orientation = xlRowField
        .Position = 1
    End With
    Set pf = pvt.PivotFields("column 2")
    With pf
        .Orientation = xlColumnField
        .Position = 1
    End With
    Set pfd = pvt.PivotFields("column 2")
    With pfd
        .Position = 1
        .Orientation = xlDataField
        .Function = xlCount
        .Caption = "Count of Col 2"
    End With

    shtP.Cells(1, 1).Select
    sht.Select
    sht.Cells(1, 1).Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
       
    Set pvt = nothing
    Set pf = nothing
    Set pfd = nothing
    Set shtP = nothing
    Set shtS = Nothing
    Set sht = Nothing
    Set wrk = Nothing
   
End Sub

---

Just a bit wierd creating the field then changing to a data one. But works !