Mrrrr
AdMiN
 Inregistrat: acum 17 ani
Postari: 2186
|
|
Assuming my Excel doesn't have a "Pivot" worksheet, the code below starts with adding one.
In "Sheet1" of the Excel file I have a bunch of raw data in a table.
Const ExcelFileName = "EXPORT.XLSX"
Public AAAA, BBBB, CCCC, DDDD
AAAA = Array("A1", "B2", "C3", "D4", "E5", "F6")
BBBB = Array("G7", "H8", "I9", "J1", "K2", "L3", "M4", "N5", "O6")
CCCC = Array("P7", "Q8", "R9")
DDDD = Array("S1", "T2", "U3", "V4", "W5", "X6", "Y7", "Z8")
Const xlUp = -4162
Const xlLeft = -4159
Const xlDatabase = 1
Const Version = 5
Const Destination = "PIVOT!R3C1"
Const TableName = "MyPivot"
Const xlRowField = 1
Const xlColumnField = 2
Const xlFilterField = 3
Const xlDataField = 4
Sub CreatePivot
Dim objXL, wb, ws, wsPvt, i, obj
On Error Resume Next
Set objXL = GetObject(, "Excel.Application")
If objXL Is Nothing Then
MsgBox "No Excel file open.", vbOkOnly, "Excel not found!"
Exit Sub
End If
' http://mrrrr.3xforum.ro/post/2262/1/VBS_Check_if_Excel_file_is_Open/
If Err Then
If Err.Number = 429 Then
WScript.Echo "No Excel file open.", vbOkOnly, "Excel not found!"
Else
WScript.Echo Err.Description & " (0x" & Hex(Err.Number) & ")"
End If
WScript.Quit 1
End If
On Error Goto 0
Set wb = Nothing
For Each obj In objXL.Workbooks
If obj.Name = ExcelFileName Then 'use obj.FullName for full path
Set wb = obj
Exit For
End If
Next
If wb Is Nothing Then
WScript.Echo "Workbook not open."
WScript.Quit 1
End If
Set ws = wb.Worksheets("Sheet1")
With ws
LR = .Cells(.Rows.Count, "D").End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlLeft).Column
If .Cells(LR, 4).Value = "" Then
LR = LR - 1
End If
If .Cells(1, LC).Value = "Type" Then
For each cell in .Range("D2:D" & LR)
If cell.Value <> "" Then
If IsNumeric(objXL.Match(cell.value, AAAA, 0)) Then
cell.offset(0, LC-4).Value = "AAAA"
ElseIf IsNumeric(objXL.Match(cell.value, BBBB, 0)) Then
cell.offset(0, LC-4).Value = "BBBB"
ElseIf IsNumeric(objXL.Match(cell.value, CCCC, 0)) Then
cell.offset(0, LC-4).Value = "CCCC"
ElseIf IsNumeric(objXL.Match(cell.value, DDDD, 0)) Then
cell.offset(0, LC-4).Value = "DDDD"
Else
MsgBox "The Line in cell " & cell.address & " does not exist in the arrays. " & VBCrlf & _
"Contact Mrrrr for code update.", vbOkOnly, "Unknown Line"
i = "error"
End If
End If
Next
Else
.Cells(1, LC+1).Value = "Type"
For each cell in .Range("D2:D" & LR)
If cell.Value <> "" Then
If IsNumeric(objXL.Match(cell.value, AAAA, 0)) Then
cell.offset(0, LC-3).Value = "AAAA"
ElseIf IsNumeric(objXL.Match(cell.value, BBBB, 0)) Then
cell.offset(0, LC-3).Value = "BBBB"
ElseIf IsNumeric(objXL.Match(cell.value, CCC, 0)) Then
cell.offset(0, LC-3).Value = "CCCC"
ElseIf IsNumeric(objXL.Match(cell.value, DDDD, 0)) Then
cell.offset(0, LC-3).Value = "DDDD"
Else
MsgBox "The Line in cell " & cell.address & " does not exist in the arrays. " & VBCrlf & _
"Contact Mrrrr for code update.", vbOkOnly, "Unknown Line"
i = "error"
End If
End If
Next
End If
If i = "error" Then
Exit Sub
End If
' get new last column
LC = .Cells(1, .Columns.Count).End(xlLeft).column
End With
' On Error Resume Next
For i = 1 to wb.Worksheets.Count
If wb.Worksheets(i).Name = "PIVOT" Then
If Msgbox("There is already a sheet called PIVOT. " & _
"Do you want to delete it and create new?", vbYesNo, "Error") = vbNo Then
Exit Sub
Else
objXL.DisplayAlerts = False
wb.Worksheets("PIVOT").Delete
objXL.DisplayAlerts = True
End If
End If
Next
Set objSheet = wb.Worksheets.Add(, wb.Worksheets(wb.Worksheets.Count))
objSheet.Name = "PIVOT"
Set wsPvt = wb.Worksheets("PIVOT")
SrcData = "Sheet1!R1C1:R" & LR & "C" & LC
Set pvtCache = wb.PivotCaches.Create(xlDatabase,SrcData,Version)
Set pvtTable = pvtCache.CreatePivotTable(Destination,TableName)
pvtTable.pivotFields("ZZZZ").orientation = xlFilterField
pvtTable.CalculatedFields.Add "Calc GG vs HH", "=ROUND('Real GG' /'Real HH',3)", True
pvtTable.pivotFields("Calc GG vs HH").orientation = xlDataField
pvtTable.CalculatedFields.Add "Calc JJ vs KK", "=ROUND('Reb JJ' /'Reb KK',3)", True
pvtTable.pivotFields("Calc JJ vs KK").orientation = xlDataField
' field types: xlRowField, xlColumnField, xlFilterField, xlDataField
pvtTable.pivotFields("YYYY").orientation = xlFilterField
pvtTable.pivotFields("WWWW").orientation = xlFilterField
pvtTable.pivotFields("XXXX").orientation = xlFilterField
pvtTable.pivotFields("VVVV").orientation = xlFilterField
' now add slicer
Dim slCache, SL
Set slCache = wb.SlicerCaches.Add2(pvtTable, "Type")
' Syntax: Slicers.Add(SlicerDestination, Level, Name, Caption, Top, Left, Width, Height)
Set SL = slCache.Slicers.Add(wsPvt, , "Type", "Line Type")
SL.Top = 160
SL.Left = 490
SL.Width = 144
SL.Height = 188
SL.Style = "SlicerStyleDark1"
' SL.ColumnWidth = 144
' SL.RowHeight = 188
End Sub |
_______________________________________
|
|
