Mijn vraag:
Na het doorklikken (of rechtermuisknop: details weergeven) op data in een draaitabel wil ik de output die gegenereerd wordt automatisch opmaken. (Een aantal kolommen verbergen, etc)
Met mijn oplosssing werkt het, als ik Windows en daarmee Excel op Engels heb staan. Echter: als ik Excel in Nederlands heb staan werkt het niet....
.
Relevante software en hardware die ik gebruik:
Excel 2016 + VBA
Wat ik al gevonden of geprobeerd heb
Ik vermoed dat het ergens moet zitten in gebruik van niet-VBA taal, of gebruik van datums o.i.d. Het gebruik van WAAR ipv TRUE heeft ook geen verandering opgeleverd.
In VBA gebruik in de volgende code (van een collega, uit dienst..), gecombineerd met een werkblad "Drill Down":
Werkblad "Drill Down" bevat een tabel als:
Workbook:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim tblNew As ListObject
On Error Resume Next
Set tblNew = Cells(1).ListObject
If tblNew Is Nothing Then Exit Sub
Call Format_PT_Detail(tblNew)
Set tblNew = Nothing
End Sub
Worksheet:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'---If user double-clicks in PivotTable data, assigns a string reference to
'--- the Pivot Table's SourceData Property to Public string sSourceDataR1C1
On Error GoTo ResetPublicString
With Target.PivotCell
If .PivotCellType = xlPivotCellValue And _
.PivotTable.PivotCache.SourceType = xlDatabase Then
sSourceDataR1C1 = .PivotTable.SourceData
End If
End With
Exit Sub
ResetPublicString:
sSourceDataR1C1 = vbNullString
End Sub
Module:
Public sSourceDataR1C1 As String
Public Function Format_PT_Detail(tblNew As ListObject)
'---Called by Workbook_NewSheet; Passes ShowDetai table object
'---Uses Pivot Table's SourceData Property stored in Public sSourceDataR1C1
'--- to read apply NumberFormats in first row of SourceData to tblNew
Dim cSourceTopLeft As Range
Dim lCol As Long
Dim sSourceDataA1 As String
If sSourceDataR1C1 = vbNullString Then Exit Function
sSourceDataA1 = Application.ConvertFormula(sSourceDataR1C1, xlR1C1, xlA1)
Set cSourceTopLeft = Range(sSourceDataA1).Cells(1)
With tblNew
For lCol = 1 To .Range.Columns.Count
.ListColumns(lCol).Range.NumberFormat = cSourceTopLeft(2, lCol).NumberFormat
Next lCol
'Optional to do additional formatting
Call Format_Table(tbl:=tblNew, rFieldFormats:=Sheets("Drill Down").Range("A1").CurrentRegion)
tblNew.Unlist 'Optional: Converts Table to Standard Range
.Cells(1).Select
End With
sSourceDataR1C1 = vbNullString
cSourceTopLeft = Nothing
End Function
Private Function Format_Table(tbl As ListObject, rFieldFormats As Range)
'---Uses the information in rFieldFormats to format the Table
' 3 columns in rFieldFormats define: Field | Property | New Property Value
' Example Net Sales | NumberFormat | "$#,##0.00"
Dim c As Range
Dim sField As String, sFieldRef As String
Dim sProperty As String, sNewValue As String
On Error Resume Next
For Each c In rFieldFormats.Resize(, 1)
sField = c(1, 1)
sProperty = c(1, 2)
sNewValue = c(1, 3)
sNewValue = Replace(sNewValue, """", "") 'remove any quotes
sFieldRef = tbl.Name & "[" & sField & "]"
With Range(sFieldRef)
Select Case sProperty
Case "Color"
.Interior.Color = sNewValue
Case "Delete"
.EntireColumn.Delete
Case "Font"
.Font = sNewValue
Case "Hidden"
.EntireColumn.Hidden = sNewValue
Case "NumberFormat"
.NumberFormat = sNewValue
Case "Autofit"
.EntireColumn.AutoFit
Case "Width"
.ColumnWidth = sNewValue
Case "Wrap"
.WrapText = sNewValue
Case ""
'---No formatting changes
Case "Property or Method"
'---Skip rFieldFormats Header Row
Case Else
MsgBox sProperty & " is not a defined Property " & "or Method in Function Format_Table"
End Select
End With
Next c
Set c = Nothing
End Function
Het is een heel verhaal, wie weet kan iemand helpen..
Na het doorklikken (of rechtermuisknop: details weergeven) op data in een draaitabel wil ik de output die gegenereerd wordt automatisch opmaken. (Een aantal kolommen verbergen, etc)
Met mijn oplosssing werkt het, als ik Windows en daarmee Excel op Engels heb staan. Echter: als ik Excel in Nederlands heb staan werkt het niet....
.Relevante software en hardware die ik gebruik:
Excel 2016 + VBA
Wat ik al gevonden of geprobeerd heb
Ik vermoed dat het ergens moet zitten in gebruik van niet-VBA taal, of gebruik van datums o.i.d. Het gebruik van WAAR ipv TRUE heeft ook geen verandering opgeleverd.
In VBA gebruik in de volgende code (van een collega, uit dienst..), gecombineerd met een werkblad "Drill Down":
Werkblad "Drill Down" bevat een tabel als:
| Data Source Header | Property or Method | Value |
| Kolomnaam1 | Hidden | TRUE |
Workbook:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim tblNew As ListObject
On Error Resume Next
Set tblNew = Cells(1).ListObject
If tblNew Is Nothing Then Exit Sub
Call Format_PT_Detail(tblNew)
Set tblNew = Nothing
End Sub
Worksheet:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'---If user double-clicks in PivotTable data, assigns a string reference to
'--- the Pivot Table's SourceData Property to Public string sSourceDataR1C1
On Error GoTo ResetPublicString
With Target.PivotCell
If .PivotCellType = xlPivotCellValue And _
.PivotTable.PivotCache.SourceType = xlDatabase Then
sSourceDataR1C1 = .PivotTable.SourceData
End If
End With
Exit Sub
ResetPublicString:
sSourceDataR1C1 = vbNullString
End Sub
Module:
Public sSourceDataR1C1 As String
Public Function Format_PT_Detail(tblNew As ListObject)
'---Called by Workbook_NewSheet; Passes ShowDetai table object
'---Uses Pivot Table's SourceData Property stored in Public sSourceDataR1C1
'--- to read apply NumberFormats in first row of SourceData to tblNew
Dim cSourceTopLeft As Range
Dim lCol As Long
Dim sSourceDataA1 As String
If sSourceDataR1C1 = vbNullString Then Exit Function
sSourceDataA1 = Application.ConvertFormula(sSourceDataR1C1, xlR1C1, xlA1)
Set cSourceTopLeft = Range(sSourceDataA1).Cells(1)
With tblNew
For lCol = 1 To .Range.Columns.Count
.ListColumns(lCol).Range.NumberFormat = cSourceTopLeft(2, lCol).NumberFormat
Next lCol
'Optional to do additional formatting
Call Format_Table(tbl:=tblNew, rFieldFormats:=Sheets("Drill Down").Range("A1").CurrentRegion)
tblNew.Unlist 'Optional: Converts Table to Standard Range
.Cells(1).Select
End With
sSourceDataR1C1 = vbNullString
cSourceTopLeft = Nothing
End Function
Private Function Format_Table(tbl As ListObject, rFieldFormats As Range)
'---Uses the information in rFieldFormats to format the Table
' 3 columns in rFieldFormats define: Field | Property | New Property Value
' Example Net Sales | NumberFormat | "$#,##0.00"
Dim c As Range
Dim sField As String, sFieldRef As String
Dim sProperty As String, sNewValue As String
On Error Resume Next
For Each c In rFieldFormats.Resize(, 1)
sField = c(1, 1)
sProperty = c(1, 2)
sNewValue = c(1, 3)
sNewValue = Replace(sNewValue, """", "") 'remove any quotes
sFieldRef = tbl.Name & "[" & sField & "]"
With Range(sFieldRef)
Select Case sProperty
Case "Color"
.Interior.Color = sNewValue
Case "Delete"
.EntireColumn.Delete
Case "Font"
.Font = sNewValue
Case "Hidden"
.EntireColumn.Hidden = sNewValue
Case "NumberFormat"
.NumberFormat = sNewValue
Case "Autofit"
.EntireColumn.AutoFit
Case "Width"
.ColumnWidth = sNewValue
Case "Wrap"
.WrapText = sNewValue
Case ""
'---No formatting changes
Case "Property or Method"
'---Skip rFieldFormats Header Row
Case Else
MsgBox sProperty & " is not a defined Property " & "or Method in Function Format_Table"
End Select
End With
Next c
Set c = Nothing
End Function
Het is een heel verhaal, wie weet kan iemand helpen..