' *** MODULE POUR LA FEUILLE CLIENTS$ ***
'---------------------------------------------------------------------------------------
' Procedure : CreateConnection
' Author : KL (Kirill Lapin)
' Date : 18/08/2009
' Updated : 27/09/2010
' Purpose : Demonstration
' Comments : Special thanks to
' Debra Dalgleish for helping to fix ODBC driver issue
' Hector Miguel Orozco Diaz for the "DeleteConnections_12" idea
' Ron de Bruin for his tip on FileFormat selection
'---------------------------------------------------------------------------------------
Option Explicit
Const PIVOTNAME = "TestPivot"
Dim strFileExt As String
Dim lngFileFormat As Long
'
Sub CreateConnection_client()
Dim PT As PivotTable
Dim PC As PivotCache
Dim strFile As String
Dim strFileTemp As String
Dim strPath As String
Dim arrSheets As Variant
Dim strSQL As String
Dim strCon As String
Dim i As Long
' Sheets to consolidate
'*****************************************************************************
arrSheets = Array("Ventes 10-11", "ventes 09-10", "ventes 08-09", "ventes 07-08")
'*****************************************************************************
If Val(Application.Version) > 11 Then
DeleteConnections_client
CheckFileFormat_client
Else
strFileExt = ".xls"
lngFileFormat = xlNormal
End If
Application.ScreenUpdating = False
With ThisWorkbook
strPath = .Path
strFile = .FullName
strFileTemp = strPath & "\DBtemp" & format(Now, "yyyymmddhhmmss") & strFileExt
ActiveSheet.Cells.Clear
.Worksheets(arrSheets).Copy
End With
With ActiveWorkbook
.SaveAs strFileTemp, lngFileFormat
.Close
End With
For i = LBound(arrSheets) To UBound(arrSheets)
If arrSheets(i) <> ActiveSheet.Name Then
If strSQL = "" Then
strSQL = "SELECT * FROM [" & arrSheets(i) & "$]"
Else
strSQL = strSQL & " UNION ALL SELECT * FROM [" & arrSheets(i) & "$]"
End If
End If
Next i
strCon = _
"ODBC;" & _
"DSN=Excel Files;" & _
"DBQ=" & strFileTemp & ";" & _
"DefaultDir=" & strPath & ";" & _
"DriverId=790;" & _
"MaxBufferSize=2048;" & _
"PageTimeout=5"
Set PC = ThisWorkbook.PivotCaches.Add(SourceType:=xlExternal)
With PC
.Connection = strCon
.CommandType = xlCmdSql
.CommandText = strSQL
Set PT = .CreatePivotTable(TableDestination:=ActiveSheet.Range("A7"))
PT.Name = "TestPivot"
End With
With PT.PivotCache
.Connection = Replace(strCon, strFileTemp, strFile)
End With
'Clean up
Kill strFileTemp
Set PT = Nothing
Set PC = Nothing
End Sub
Sub ReestablishConnection_client()
Dim strFile As String
Dim strPath As String
Dim strCon As String
With ThisWorkbook
strPath = .Path
strFile = .FullName
strCon = _
"ODBC;" & _
"DSN=Excel Files;" & _
"DBQ=" & strFile & ";" & _
"DefaultDir=" & strPath & ";" & _
"DriverId=790;" & _
"MaxBufferSize=2048;" & _
"PageTimeout=5"
' With .Worksheets("clients$")
' If .PivotTables.Count > 0 Then .PivotTables(PIVOTNAME).PivotCache.Connection = strCon
' End With
End With
End Sub
Private Sub DeleteConnections_client()
Dim con
Dim PT As PivotTable
' This line won't work and wouldn't be necessary
' in the versions older than 2007
'*****************************************************************************
On Error Resume Next
With ThisWorkbook
Set PT = .Worksheets("client$").PivotTables(PIVOTNAME)
For Each con In .Connections
If con.ODBCConnection.Connection = PT.PivotCache.Connection _
And con.ODBCConnection.CommandText = PT.PivotCache.CommandText Then
con.Delete
End If
Next con
End With
On Error GoTo 0
'*****************************************************************************
End Sub
Sub CheckFileFormat_client()
With ThisWorkbook
Select Case .FileFormat
Case 51: strFileExt = ".xlsx": lngFileFormat = 51
Case 52:
If .HasVBProject Then
strFileExt = ".xlsm": lngFileFormat = 52
Else
strFileExt = ".xlsx": lngFileFormat = 51
End If
Case 56: strFileExt = ".xls": lngFileFormat = 56
Case Else: strFileExt = ".xlsb": lngFileFormat = 50
End Select
End With
End Sub
Sub SamplePivot_client()
Dim PT As PivotTable
CreateConnection_client
Set PT = ThisWorkbook.Worksheets("clients$").PivotTables(PIVOTNAME)
With PT
With .PivotFields(3) 'client nom des lignes
.Orientation = xlRowField
.Position = 1
End With
.AddDataField .PivotFields(9), "Valeur CDN $", xlSum 'Total CDN Valeur à calculer
.AddDataField .PivotFields(4), "Nbre ventes", xlCount 'nbre de ventes valeur à calculer
'mise en forme monétaire et nombre
PT.PivotFields("valeur CDN $").NumberFormat = "#,##0.00 $"
PT.PivotFields("Nbre ventes").NumberFormat = "#,###"
With .PivotFields(1) 'type ventes champs pour faire un trie
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields(15) 'Année nom des colonnes
.Orientation = xlColumnField
.Position = 1
' code pour extraire le mois et l'année d'une date
' .DataRange.Cells(1).Group _
' Start:=True, _
' End:=True, _
' Periods:=Array(False, False, False, False, True, False, True)
End With
End With
'Clean up
Set PT = Nothing
Application.ScreenUpdating = True
'formater colonne et ligne et masquer blank client
' enlève la colonne grand total qui s'inclut automatiquement dans le tableau
Range("A8").Select
With ActiveSheet.PivotTables("TestPivot").PivotFields("Année")
.PivotItems("(blank)").Visible = False
End With
' enlève la ligne blank des clients
Range("A8").Select
With ActiveSheet.PivotTables("TestPivot").PivotFields("client")
.PivotItems("(blank)").Visible = False
End With
ActiveSheet.PivotTables("TestPivot").TableStyle2 = "PivotTable Style 1"
Range("A1").Select
Sheets("clients$").Select
ActiveCell.FormulaR1C1 = "Analyse des ventes par clients"
Range("A1:G1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6692904
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Selection.Font.Bold = True
Range("E5").Select
' mise en forme couleur 1 ligne sur 2
'Dim cellule As Range
'A10 est la cellule à partir de laquel je veux que les lignes se colore 1 / 2
' Range("A10:G" & Range("A65536").End(xlUp).Row).Select
' For Each cellule In Selection
' If cellule.Row Mod 2 = 0 Then
' With cellule
' .Interior.ColorIndex = 47
' End With
' Else: With cellule
' .Interior.ColorIndex = xlNone
' End With
' End If
' Next
Dim i As Long
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
' 2 = la colonne B 7 la colonne G
If Cells(i, 2) = "Valeur CDN $" Then Range(Cells(i, 2), Cells(i, 7)).Interior.ColorIndex = 0
If Cells(i, 2) = "Nbre ventes" Then Range(Cells(i, 1), Cells(i, 7)).Interior.ColorIndex = 47
Next i
End Sub