[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 374
  • Last Modified:

open a spreadsheet and do a pivot table macro

Hi,
I want to open a spreadsheet and do a pivot table using a macro.

The spreadsheet will be on the desktop and will vary on the file name. therefore, I'd when the macro starts, i'd like to browse for the file, open, then perform the pivot table.

At the end i'd like to display a msgbox showing the date in A2, to confirm the correct report was run.

Exchange (Row Labels), Date (Column Labels), Quantity (Values) – SUM not count                                          
I'd like to copy all data from A5:B (last row with data), not including if A, has a value of (blank).

Sheet1 is the name of the filename (minus the file extension). I'd prefer not to specify, but if i have to, I need to make it this. I need to replace  "Dec2013" with whatever Sheet1 may be named (which would be the filename minus extension).

Ive given a go so far. I can get it working up to the point where it opens the file, just need assistance with the Sheet1 part mentioned. then need some help with the actual pivot, and the copy of the data mentioned above.

here is my code thus far:

Dim wsClient As Worksheet
Dim wkbClient As Workbook
Dim wkbThis As Workbook
Dim pivotdate As String

Sub PivotN()
'start code
 Set wkbThis = ThisWorkbook
  
  ' Open Client Workbook
  Set wkbClient = OpenWorkbook(True)
  ' Set wkbClient = OpenWorkbook1()
    LetsPivot ' calls pivot table sub
    pivotdate = wkbClient.Sheets("Dec2013").Range("A2").Value
    MsgBox ("Pivot Table Complete [" & pivotdate & "]. Data copied. Now paste.")
    
  If wkbClient Is Nothing Then
    MsgBox "No valid workbook has been provided, Exiting..."
    Exit Sub
  Else
    ' If we know the worksheet name
    ' clientWSName = "Foglio1"
    ' Find the client worksheet by name
    ' Set wsClient = wkbClient.Sheets(clientWSName)
    ' This assumes the client worksheet is the first
    If (wkbClient.Worksheets.Count > 0) Then
       Set wsClient = wkbClient.Worksheets(1)
    Else
       MsgBox "Unable to process - no worksheet available"
       Exit Sub
    End If
    
    If (wsClient Is Nothing) Then
      MsgBox "Null client worksheet..."
      Exit Sub
    Else
      ' MsgBox "Got a client worksheet: " & wsClient.UsedRange.Count
    End If
    
     End If
    
End Sub
' Function to open a workbook using the File Dialog
Public Function OpenWorkbook(mode As Boolean) As Excel.Workbook
Dim sFile As String
Dim ShortName As String
Dim autoSecurity As MsoAutomationSecurity
Set OpenWorkbook = Nothing
Dim wkb As Workbook

autoSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable

With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Filters.Clear
    .Filters.Add "Excel Files", "*.csv"
    .FilterIndex = 1
    .Title = "Please Select File to open"
    If .Show = False Then Exit Function
    sFile = .SelectedItems(1)
    End With

ShortName = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))

If CheckSourceAvailability(ShortName) Then
  Workbooks(ShortName).Close
End If

Application.EnableEvents = False
If (mode) Then
  Set wkb = Workbooks.Open(sFile, ReadOnly:=True, UpdateLinks:=0)
  On Error GoTo 0
Else
  Set wkb = Workbooks.Open(sFile)
End If
Application.EnableEvents = True

Set OpenWorkbook = wkb
Debug.Print OpenWorkbook.Name
clientFileName = sFile
Application.AutomationSecurity = autoSecurity

errOpen:
  If (Err.Number > 0) Then
    MsgBox "Error: " & Err.Description & "ErrNo: " & Err.Number
  End If

End Function
Public Function CheckSourceAvailability(sWorkBook As String) As Boolean
    Dim wb As Workbook, bResult As Boolean
    bResult = False
    For Each wb In Application.Workbooks
        If InStr(LCase(wb.Name), LCase(sWorkBook)) > 0 Then
            bResult = True
            Exit For
        End If
    Next wb
    CheckSourceAvailability = bResult
End Function

Sub LetsPivot()

    Const SourceSheet As String = ""
    Const PivotName As String = "PivotN"
    Const TargetCell As String = "A1"
    
    Const ColumnCaptions As String = "Date"
    
    ThisWorkbook.ShowPivotTableFieldList = False
End Sub

Open in new window

0
jfrank14
Asked:
jfrank14
  • 5
  • 5
2 Solutions
 
Harry LeeCommented:
jfrank14,

I can get the VBA macro setup for you.

Can you please upload a sample file for me?
0
 
jfrank14Author Commented:
see attached:
sample-Dec2013.csv
0
 
Harry LeeCommented:
jfrank14,

Please try the following code. This code is meant to be stored in the personal macro library instead of the working file.


Sub CreatePivotTable()

Dim NewFN As Workbook
Dim curWorkbook As Workbook
'
'-----------------------------------------------------------'
'   Request New Excel File
'
    NewFFN = Application.GetOpenFilename(Title:="PLEASE SELECT AN ACKLAND SMS REPORT FILE")
    If NewFFN = False Then
        MsgBox "Macro Terminated Due to No File Selected"
        Exit Sub
        Else
            Workbooks.Open Filename:=NewFFN
    End If
    Set NewFN = ActiveWorkbook
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Save File with Suffix "Pivot Table"

    OrgFName = ActiveWorkbook.Name
    OrgFFName = ActiveWorkbook.FullName
    Fnamelength = Len(OrgFName)
    OrgfPath = Left(OrgFFName, Len(OrgFFName) - Fnamelength)
    NewFName = Left(OrgFName, InStr(OrgFName, ".") - 1) & " Pivot Table"
    NewFFName = OrgfPath & NewFName

    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs NewFFName, FileFormat:=50
    Application.DisplayAlerts = True
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Record Report Date
'
    Dim RptDate As String
    RptDate = ActiveSheet.Range("A2")
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Turn off screen update and calculation to speed up macro
'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Duplicate sheet for backup
'
    ActiveSheet.Copy Before:=Sheets(1)
    Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Correct number stored as text
'
Dim I2 As Object
    For Each I2 In ActiveSheet.UsedRange
        I2 = I2.Value
    Next I2
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Delete unwanted rows (Column A is Blanks).
'
    With ActiveSheet
        .AutoFilterMode = False
        With Range("A1:A100000")
            .AutoFilter 1, "="
            On Error Resume Next
            Range("A2:A100000").SpecialCells(12).EntireRow.Delete
        End With
        .AutoFilterMode = False
    End With
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Active Sheet Auto Fit
'
    ActiveSheet.Columns.AutoFit
    Set curWorkbook = ActiveWorkbook
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Page Setup to fit on 1 page wide
'
    With ActiveSheet.PageSetup
        .Orientation = xlPortrait
        .PaperSize = xlPaperLetter
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
    End With
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Create Pivot Table to obtain summary
'
    ActiveSheet.UsedRange.Select
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        Sheets(1).UsedRange).CreatePivotTable TableDestination:="", _
        TableName:="Pivot Summary", DefaultVersion:=xlPivotTableVersion10
    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
    ActiveSheet.Cells(3, 1).Select
    With ActiveSheet.PivotTables("Pivot Summary").PivotFields("Exchange")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("Pivot Summary").PivotFields("Date")
        .Orientation = xlColumnField
        .Position = 1
    End With
    ActiveSheet.PivotTables("Pivot Summary").AddDataField ActiveSheet.PivotTables( _
        "Pivot Summary").PivotFields("Traded Quantity"), "Sum of Traded Quantity", _
        xlSum
    ActiveSheet.Columns.AutoFit
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Re-enable screen update and calculations
'
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Range("A1").Select
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Save Workbook
'
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    Application.DisplayAlerts = True
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Report Completion Notification
'
    MsgBox ("Pivot Summary For Report " & RptDate & " is Completed")

End Sub

Open in new window

0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
jfrank14Author Commented:
perfect, thanks!

How can I add at the end to copy:
A5:B(last row). Not including the grant total line?

Then in the msgbox, i'll add:

MsgBox ("Pivot Summary For Report " & RptDate & " is Completed. Data copied to clipboard.")

Thanks!
0
 
Harry LeeCommented:
jFrank14,

I think this is what you need.

Sub CreatePivotTable()

Dim NewFN As Workbook
Dim curWorkbook As Workbook
'
'-----------------------------------------------------------'
'   Request New Excel File
'
    NewFFN = Application.GetOpenFilename(Title:="PLEASE SELECT AN ACKLAND SMS REPORT FILE")
    If NewFFN = False Then
        MsgBox "Macro Terminated Due to No File Selected"
        Exit Sub
        Else
            Workbooks.Open Filename:=NewFFN
    End If
    Set NewFN = ActiveWorkbook
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Save File with Suffix "Pivot Table"

    OrgFName = ActiveWorkbook.Name
    OrgFFName = ActiveWorkbook.FullName
    Fnamelength = Len(OrgFName)
    OrgfPath = Left(OrgFFName, Len(OrgFFName) - Fnamelength)
    NewFName = Left(OrgFName, InStr(OrgFName, ".") - 1) & " Pivot Table"
    NewFFName = OrgfPath & NewFName

    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs NewFFName, FileFormat:=50
    Application.DisplayAlerts = True
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Record Report Date
'
    Dim RptDate As String
    RptDate = ActiveSheet.Range("A2")
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Turn off screen update and calculation to speed up macro
'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Duplicate sheet for backup
'
    ActiveSheet.Copy Before:=Sheets(1)
    Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Correct number stored as text
'
Dim I2 As Object
    For Each I2 In ActiveSheet.UsedRange
        I2 = I2.Value
    Next I2
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Delete unwanted rows (Column A is Blanks).
'
    With ActiveSheet
        .AutoFilterMode = False
        With Range("A1:A100000")
            .AutoFilter 1, "="
            On Error Resume Next
            Range("A2:A100000").SpecialCells(12).EntireRow.Delete
        End With
        .AutoFilterMode = False
    End With
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Active Sheet Auto Fit
'
    ActiveSheet.Columns.AutoFit
    Set curWorkbook = ActiveWorkbook
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Page Setup to fit on 1 page wide
'
    With ActiveSheet.PageSetup
        .Orientation = xlPortrait
        .PaperSize = xlPaperLetter
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
    End With
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Create Pivot Table to obtain summary
'
    ActiveSheet.UsedRange.Select
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        Sheets(1).UsedRange).CreatePivotTable TableDestination:="", _
        TableName:="Pivot Summary", DefaultVersion:=xlPivotTableVersion10
    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
    ActiveSheet.Cells(3, 1).Select
    With ActiveSheet.PivotTables("Pivot Summary").PivotFields("Exchange")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("Pivot Summary").PivotFields("Date")
        .Orientation = xlColumnField
        .Position = 1
    End With
    ActiveSheet.PivotTables("Pivot Summary").AddDataField ActiveSheet.PivotTables( _
        "Pivot Summary").PivotFields("Traded Quantity"), "Sum of Traded Quantity", _
        xlSum
    ActiveSheet.Columns.AutoFit
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Re-enable screen update and calculations
'
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Range("A1").Select
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Save Workbook
'
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    Application.DisplayAlerts = True
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Copy Data Into Clipboard
'
    Dim CopyRng As Range, LastPivotRow As Long
    LastPivotRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
    Set CopyRng = Range(Cells(5, 1), Cells(LastPivotRow, 2))
    CopyRng.Value.Copy
'
'-----------------------------------------------------------
'-----------------------------------------------------------
'   Report Completion Notification
'
    MsgBox ("Pivot Summary For Report " & RptDate & " is Completed. Data is Copied to Clipboard.")

End Sub

Open in new window

0
 
jfrank14Author Commented:
thanks for the above. MSGbox looks good, no errors, however doesnt actually copy the data.

when I go to paste into another sheet just to test, its not in the clipboard.

Is it copying data from A5 to B (last row) ?
(not including Grand total Line) ?

not sure why its not pasting.

thanks.
0
 
Harry LeeCommented:
jFrank14,

when you look into the code line 138 - 144, that's where the copy happens. You have to make sure you don't press ESC to cancel the copy.

I can program the VBA to put into into the clipboard, but it involve Enabling the Microsoft Forms 2.0 Run-Time library in order to do so, and it's not working very well.

What exactly do you want to achieve putting the pivot table data into the clipboard? Are you pasting it in another excel file, Email, or some other software such as text editor?
0
 
jfrank14Author Commented:
yea, want to paste (as values) into another file (in excel) which will be open in specific area.
0
 
Harry LeeCommented:
jFrank14,

Sorry for a minor error. Please modify line 143 from
CopyRng.Value.Copy
to
CopyRng.Copy

I have forgotten to remove the .Value from it.
0
 
jfrank14Author Commented:
awesome! works like a charm. thanks again!
0

Featured Post

The 14th Annual Expert Award Winners

The results are in! Meet the top members of our 2017 Expert Awards. Congratulations to all who qualified!

  • 5
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now