Results 1 to 3 of 3

Thread: [RESOLVED] Excel - pivot table - vba

  1. #1

    Thread Starter
    Don't Panic! Ecniv's Avatar
    Join Date
    Nov 2000
    Location
    Amsterdam...
    Posts
    5,343

    Resolved [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)

    BOFH Now, BOFH Past, Information on duplicates

    Feeling like a fly on the inside of a closed window (Thunk!)
    If I post a lot, it is because I am bored at work! ;D Or stuck...
    * Anything I post can be only my opinion. Advice etc is up to you to persue...

  2. #2
    PowerPoster
    Join Date
    Dec 2004
    Posts
    25,618

    Re: Excel - pivot table - vba

    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
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  3. #3

    Thread Starter
    Don't Panic! Ecniv's Avatar
    Join Date
    Nov 2000
    Location
    Amsterdam...
    Posts
    5,343

    Re: Excel - pivot table - 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 !

    BOFH Now, BOFH Past, Information on duplicates

    Feeling like a fly on the inside of a closed window (Thunk!)
    If I post a lot, it is because I am bored at work! ;D Or stuck...
    * Anything I post can be only my opinion. Advice etc is up to you to persue...

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width