Option Explicit Public Erreur As String 'Public LigneTab(1 To 20) As Variant Public LigneTab(1 To 1000, 1 To 10000) As Variant ' table à deux dimensions Public XLMain As String Public NOMBRE As Integer Public NOMBRE_EXCEL As Integer Public NBR_CHAMPS As Integer Public NomOnglet As String Sub tmp_deb() RetrieveData End Sub Sub Auto_Open() 'ne pas executer le code si NOEXEC est present dans le repertoire. If ExistFile(GetFilePath(Environ("RESULTO")) + "\NOEXEC") Then MsgBox "fichier d'arret NOEXEC trouve" End End If Application.ReferenceStyle = xlA1 XLMain = ActiveWorkbook.Name RetrieveData End Sub Function ExistFile(strPath As String) As Boolean Dim fs As Object Dim blnFExiste As Boolean Set fs = CreateObject("Scripting.FileSystemObject") If Not (fs.FileExists(strPath)) Then blnFExiste = False Else blnFExiste = True End If ExistFile = blnFExiste End Function 'ouvre le classeur des donnees en entree Sub OuvrirFichierXL(ByVal FicTrt As String, ByRef ClassTrt As String, Erreur As String) On Error GoTo ErrorHandler Workbooks.OpenText FileName:=FicTrt, DataType:=xlDelimited, Other:=True, OtherChar:=";" 'Workbooks.OpenText FileName:= _ ' "C:\Dev\Excel\charade_avt_envoi\RESULTAT_exapaq03_AV_ENVOI.csv", Origin:= _ ' xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ ' xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=True, _ ' Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _ ' Array(2, 1), Array(3, 1), Array(4, 1)) ClassTrt = ActiveWorkbook.Name Range("B2").Select 'ActiveCell.NumberFormat = "d mmmm yyyy" 'Date Exit Sub ErrorHandler: Select Case Err.Number Case 1004 'fichier introuvable Erreur = Err.Description MsgBox Err.Description End Select Resume Next End Sub 'ferme et enregistre le nouveau classeur Sub EnregisterFermer(ClassFinal As String, NomClassIn As String) Dim NomXL As String Dim fs As New Scripting.FileSystemObject Dim recup_dossier As Variant Dim recup_resulto As String On Error Resume Next 'NomXL = Environ("RESULTO") + "\" + ChangeFileExt(NomClassIn, "xlsx") NomXL = GetFilePath(Environ("RESULTO")) + "\" + ChangeFileExt(NomClassIn, "xlsx") ' ***** Modification du nom du classeur final 18/02/2013 ******* " recup_dossier = Split(NomXL, "_") recup_resulto = recup_dossier(0) NomXL = recup_resulto + "_Statistiques_Deduplication.xlsx" 'MsgBox "Nomxl : " & NomXL fs.DeleteFile NomXL, True Workbooks(ClassFinal).Activate ActiveWorkbook.SaveAs FileName:=NomXL, CreateBackup:=False ActiveWorkbook.Close End Sub Sub Fermer() Range("F2").Select End Sub ' Retrieve a file's path ' Note: trailing backslashes are never included in the result Function GetFilePath(FileName As String) As String Dim i As Long For i = Len(FileName) To 1 Step -1 Select Case Mid$(FileName, i, 1) Case ":" ' colons are always included in the result GetFilePath = Left$(FileName, i) Exit For Case "\" ' backslash aren't included in the result GetFilePath = Left$(FileName, i - 1) Exit For End Select Next End Function ' Retrieve a file's name Private Function ExtractFileName(ByVal vStrFullPath As String) As String Dim intPos As Integer intPos = InStrRev(vStrFullPath, "\") ExtractFileName = Mid$(vStrFullPath, intPos + 1) End Function Private Function ChangeFileExt(Fichier As String, Ext As String) Dim i As Integer i = InStrRev(Fichier, ".") If i > 0 Then ChangeFileExt = Mid(Fichier, 1, i - 1) + "." + Ext Else ChangeFileExt = Fichier End If End Function 'copie des valeurs vers nouveau classeur Sub CopierValeurs(ByRef ClassFinal As String) Dim i As Double Dim l As Integer Dim lp As Integer Dim ls As Integer Dim h3 As Integer Dim c3 As Integer Dim t3 As Integer Dim tventlig As Integer Dim pourc_uniques As Double Dim pourc_repous As Double Dim pourc_1grpe As Double Dim pourc_ngrpe As Double Dim pourc_aediter As Double Dim Q As Integer Dim colonne As Integer ClassFinal = Workbooks.Add.Name Workbooks(XLMain).Activate i = 1 'nb article lu l = 12 'ligne pour la feuille deduplication lp = 12 'ligne pour la feuille deduplication DOUBLON PURS ls = 12 'ligne pour la feuille deduplication DOUBLON supposes h3 = 8 'ligne pour la feuille de ventilation v3 c3 = 0 'colonne pour la feuille de ventilation v3 t3 = 0 'index pour la table ventilation v3 tventlig = 3 'index pour le cumul ligne table ventilation v3 Q = 0 'index pour le quadriage Workbooks(XLMain).Activate ActiveWorkbook.Sheets(1).Select Sheets(1).Copy before:=Workbooks(ClassFinal).Sheets(1) 'ok Workbooks(XLMain).Activate ActiveWorkbook.Sheets(2).Select Sheets(2).Copy before:=Workbooks(ClassFinal).Sheets(2) 'ok Workbooks(XLMain).Activate ActiveWorkbook.Sheets(3).Select Sheets(3).Copy before:=Workbooks(ClassFinal).Sheets(3) 'ok Workbooks(XLMain).Activate ActiveWorkbook.Sheets(4).Select Sheets(4).Copy before:=Workbooks(ClassFinal).Sheets(4) 'ok Workbooks(XLMain).Activate ActiveWorkbook.Sheets(5).Select Sheets(5).Copy before:=Workbooks(ClassFinal).Sheets(5) 'ok Do If UCase(LigneTab(i, 1)) = "ETAT00" Then ActiveWorkbook.Sheets(1).Select Range("F7").Value = LigneTab(i, 2) 'Nom du client Range("F8").Value = Date 'date traitement Else If UCase(LigneTab(i, 1)) = "ETAT01" Then 'deduplication Range("A1").Select ActiveWorkbook.Sheets(2).Select Q = 1 l = l + 1 Cells(12, 3).Select ActiveWindow.FreezePanes = True 'figer une cellule If UCase(LigneTab(i, 2)) = "CUMUL" Then l = l + 2 End If Cells(l, 2).Font.FontStyle = "gras" Cells(l, 3).NumberFormat = "#,##0" Cells(l, 3).HorizontalAlignment = xlCenter Cells(l, 4).NumberFormat = "#,##0" Cells(l, 4).HorizontalAlignment = xlCenter Cells(l, 5).NumberFormat = "#,##0" Cells(l, 5).HorizontalAlignment = xlCenter Cells(l, 6).NumberFormat = "0.00" Cells(l, 6).HorizontalAlignment = xlCenter Cells(l, 7).NumberFormat = "#,##0" Cells(l, 7).HorizontalAlignment = xlCenter Cells(l, 8).NumberFormat = "0.00" Cells(l, 8).HorizontalAlignment = xlCenter Cells(l, 9).NumberFormat = "#,##0" Cells(l, 9).HorizontalAlignment = xlCenter Cells(l, 10).NumberFormat = "0.00" Cells(l, 10).HorizontalAlignment = xlCenter Cells(l, 11).NumberFormat = "#,##0" Cells(l, 11).HorizontalAlignment = xlCenter Cells(l, 12).NumberFormat = "0.00" Cells(l, 12).HorizontalAlignment = xlCenter Cells(l, 13).NumberFormat = "#,##0" Cells(l, 13).HorizontalAlignment = xlCenter Cells(l, 14).NumberFormat = "0.00" Cells(l, 14).HorizontalAlignment = xlCenter If UCase(LigneTab(i, 2)) = "CUMUL" Or UCase(LigneTab(i, 2)) = "HORS REPOUSSOIR" Then 'Cells(l, 2).Font.FontStyle = "gras" 'Cells(l, 2).HorizontalAlignment = xlCenter Cells(l, 3).Font.FontStyle = "gras" Cells(l, 4).Font.FontStyle = "gras" Cells(l, 5).Font.FontStyle = "gras" Cells(l, 6).Font.FontStyle = "gras" Cells(l, 7).Font.FontStyle = "gras" Cells(l, 8).Font.FontStyle = "gras" Cells(l, 9).Font.FontStyle = "gras" Cells(l, 10).Font.FontStyle = "gras" Cells(l, 11).Font.FontStyle = "gras" Cells(l, 12).Font.FontStyle = "gras" Cells(l, 13).Font.FontStyle = "gras" Cells(l, 14).Font.FontStyle = "gras" End If Cells(l, 2).Value = LigneTab(i, 2) 'Nom du fichier Cells(l, 3).Value = LigneTab(i, 3) 'nombre adresses lues Cells(l, 4).Value = LigneTab(i, 4) 'nombre adresses rejetees If LigneTab(i, 4) = "" And Cells(l, 2).Value <> "" Then Cells(l, 4).Value = 0 End If Cells(l, 5).Value = LigneTab(i, 5) 'nombre adresses uniques '** calcul du pourcentage adresses uniques If Cells(l, 2).Value <> "" Then pourc_uniques = (LigneTab(i, 5) / LigneTab(i, 3)) * 100 Cells(l, 6).Value = pourc_uniques 'pourcentage adresses uniques End If Cells(l, 7).Value = LigneTab(i, 6) 'nombre adresses repoussees '** calcul du pourcentage adresses repoussees If Cells(l, 2).Value <> "" Then pourc_repous = (LigneTab(i, 6) / LigneTab(i, 3)) * 100 Cells(l, 8).Value = pourc_repous 'pourcentage adresses repoussees End If Cells(l, 9).Value = LigneTab(i, 7) 'nombre adresses 1er de groupe '** calcul du pourcentage adresses 1er de groupe If Cells(l, 2).Value <> "" Then pourc_1grpe = (LigneTab(i, 7) / LigneTab(i, 3)) * 100 Cells(l, 10).Value = pourc_1grpe 'pourcentage adresses 1er de groupe End If Cells(l, 11).Value = LigneTab(i, 8) 'nombre adresses nieme de groupe '** calcul du pourcentage adresses nieme de groupe If Cells(l, 11).Value <> "" Then pourc_ngrpe = (LigneTab(i, 8) / LigneTab(i, 3)) * 100 Cells(l, 12).Value = pourc_ngrpe 'pourcentage adresses nieme de groupe End If Cells(l, 13).Value = LigneTab(i, 9) 'nombre adresses a editer '** calcul du pourcentage adresses à editer If Cells(l, 13).Value <> "" Then pourc_aediter = (LigneTab(i, 9) / LigneTab(i, 3)) * 100 Cells(l, 14).Value = pourc_aediter 'pourcentage adresses a editer End If 'quadriage des cellules renseignées Do ' quadriage du tableau If (UCase(LigneTab(i, 2)) = "CUMUL" Or UCase(LigneTab(i, 2)) = "HORS REPOUSSOIR") And (Q = 1) Then Else If Cells(l, Q).Value <> "" Then Cells(l, Q).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End If End If Q = Q + 1 Loop Until Q > 14 Else If UCase(LigneTab(i, 1)) = "ETAT02" Then 'deduplication doublons purs Range("A1").Select ActiveWorkbook.Sheets(3).Select Q = 1 lp = lp + 1 Cells(12, 3).Select ActiveWindow.FreezePanes = True 'figer une cellule If UCase(LigneTab(i, 2)) = "CUMUL" Then lp = lp + 2 End If Cells(lp, 2).Font.FontStyle = "gras" Cells(lp, 3).NumberFormat = "#,##0" Cells(lp, 3).HorizontalAlignment = xlCenter Cells(lp, 4).NumberFormat = "#,##0" Cells(lp, 4).HorizontalAlignment = xlCenter Cells(lp, 5).NumberFormat = "#,##0" Cells(lp, 5).HorizontalAlignment = xlCenter Cells(lp, 6).NumberFormat = "0.00" Cells(lp, 6).HorizontalAlignment = xlCenter Cells(lp, 7).NumberFormat = "#,##0" Cells(lp, 7).HorizontalAlignment = xlCenter Cells(lp, 8).NumberFormat = "0.00" Cells(lp, 8).HorizontalAlignment = xlCenter Cells(lp, 9).NumberFormat = "#,##0" Cells(lp, 9).HorizontalAlignment = xlCenter Cells(lp, 10).NumberFormat = "0.00" Cells(lp, 10).HorizontalAlignment = xlCenter Cells(lp, 11).NumberFormat = "#,##0" Cells(lp, 11).HorizontalAlignment = xlCenter Cells(lp, 12).NumberFormat = "0.00" Cells(lp, 12).HorizontalAlignment = xlCenter Cells(lp, 13).NumberFormat = "#,##0" Cells(lp, 13).HorizontalAlignment = xlCenter Cells(lp, 14).NumberFormat = "0.00" Cells(lp, 14).HorizontalAlignment = xlCenter If UCase(LigneTab(i, 2)) = "CUMUL" Or UCase(LigneTab(i, 2)) = "HORS REPOUSSOIR" Then 'Cells(l, 2).Font.FontStyle = "gras" 'Cells(l, 2).HorizontalAlignment = xlCenter Cells(lp, 3).Font.FontStyle = "gras" Cells(lp, 4).Font.FontStyle = "gras" Cells(lp, 5).Font.FontStyle = "gras" Cells(lp, 6).Font.FontStyle = "gras" Cells(lp, 7).Font.FontStyle = "gras" Cells(lp, 8).Font.FontStyle = "gras" Cells(lp, 9).Font.FontStyle = "gras" Cells(lp, 10).Font.FontStyle = "gras" Cells(lp, 11).Font.FontStyle = "gras" Cells(lp, 12).Font.FontStyle = "gras" Cells(lp, 13).Font.FontStyle = "gras" Cells(lp, 14).Font.FontStyle = "gras" End If Cells(lp, 2).Value = LigneTab(i, 2) 'Nom du fichier Cells(lp, 3).Value = LigneTab(i, 3) 'nombre adresses lues Cells(lp, 4).Value = LigneTab(i, 4) 'nombre adresses rejetees If LigneTab(i, 4) = "" And Cells(lp, 2).Value <> "" Then Cells(lp, 4).Value = 0 End If Cells(lp, 5).Value = LigneTab(i, 5) 'nombre adresses uniques '** calcul du pourcentage adresses uniques If Cells(lp, 2).Value <> "" Then pourc_uniques = (LigneTab(i, 5) / LigneTab(i, 3)) * 100 Cells(lp, 6).Value = pourc_uniques 'pourcentage adresses uniques End If Cells(lp, 7).Value = LigneTab(i, 6) 'nombre adresses repoussees '** calcul du pourcentage adresses repoussees If Cells(lp, 2).Value <> "" Then pourc_repous = (LigneTab(i, 6) / LigneTab(i, 3)) * 100 Cells(lp, 8).Value = pourc_repous 'pourcentage adresses repoussees End If Cells(lp, 9).Value = LigneTab(i, 7) 'nombre adresses 1er de groupe '** calcul du pourcentage adresses 1er de groupe If Cells(lp, 2).Value <> "" Then pourc_1grpe = (LigneTab(i, 7) / LigneTab(i, 3)) * 100 Cells(lp, 10).Value = pourc_1grpe 'pourcentage adresses 1er de groupe End If Cells(lp, 11).Value = LigneTab(i, 8) 'nombre adresses nieme de groupe '** calcul du pourcentage adresses nieme de groupe If Cells(lp, 11).Value <> "" Then pourc_ngrpe = (LigneTab(i, 8) / LigneTab(i, 3)) * 100 Cells(lp, 12).Value = pourc_ngrpe 'pourcentage adresses nieme de groupe End If Cells(lp, 13).Value = LigneTab(i, 9) 'nombre adresses a editer '** calcul du pourcentage adresses à editer If Cells(lp, 13).Value <> "" Then pourc_aediter = (LigneTab(i, 9) / LigneTab(i, 3)) * 100 Cells(lp, 14).Value = pourc_aediter 'pourcentage adresses a editer End If 'quadriage des cellules renseignées Do ' quadriage du tableau If (UCase(LigneTab(i, 2)) = "CUMUL" Or UCase(LigneTab(i, 2)) = "HORS REPOUSSOIR") And (Q = 1) Then Else If Cells(lp, Q).Value <> "" Then Cells(lp, Q).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End If End If Q = Q + 1 Loop Until Q > 14 '******************************************************** Else If UCase(LigneTab(i, 1)) = "ETAT03" Then 'deduplication doublons supposes Range("A1").Select ActiveWorkbook.Sheets(4).Select Q = 1 ls = ls + 1 Cells(12, 3).Select ActiveWindow.FreezePanes = True 'figer une cellule If UCase(LigneTab(i, 2)) = "CUMUL" Then ls = ls + 2 End If Cells(ls, 2).Font.FontStyle = "gras" Cells(ls, 3).NumberFormat = "#,##0" Cells(ls, 3).HorizontalAlignment = xlCenter Cells(ls, 4).NumberFormat = "#,##0" Cells(ls, 4).HorizontalAlignment = xlCenter Cells(ls, 5).NumberFormat = "#,##0" Cells(ls, 5).HorizontalAlignment = xlCenter Cells(ls, 6).NumberFormat = "0.00" Cells(ls, 6).HorizontalAlignment = xlCenter Cells(ls, 7).NumberFormat = "#,##0" Cells(ls, 7).HorizontalAlignment = xlCenter Cells(ls, 8).NumberFormat = "0.00" Cells(ls, 8).HorizontalAlignment = xlCenter Cells(ls, 9).NumberFormat = "#,##0" Cells(ls, 9).HorizontalAlignment = xlCenter Cells(ls, 10).NumberFormat = "0.00" Cells(ls, 10).HorizontalAlignment = xlCenter Cells(ls, 11).NumberFormat = "#,##0" Cells(ls, 11).HorizontalAlignment = xlCenter Cells(ls, 12).NumberFormat = "0.00" Cells(ls, 12).HorizontalAlignment = xlCenter Cells(ls, 13).NumberFormat = "#,##0" Cells(ls, 13).HorizontalAlignment = xlCenter Cells(ls, 14).NumberFormat = "0.00" Cells(ls, 14).HorizontalAlignment = xlCenter If UCase(LigneTab(i, 2)) = "CUMUL" Or UCase(LigneTab(i, 2)) = "HORS REPOUSSOIR" Then 'Cells(l, 2).Font.FontStyle = "gras" 'Cells(l, 2).HorizontalAlignment = xlCenter Cells(ls, 3).Font.FontStyle = "gras" Cells(ls, 4).Font.FontStyle = "gras" Cells(ls, 5).Font.FontStyle = "gras" Cells(ls, 6).Font.FontStyle = "gras" Cells(ls, 7).Font.FontStyle = "gras" Cells(ls, 8).Font.FontStyle = "gras" Cells(ls, 9).Font.FontStyle = "gras" Cells(ls, 10).Font.FontStyle = "gras" Cells(ls, 11).Font.FontStyle = "gras" Cells(ls, 12).Font.FontStyle = "gras" Cells(ls, 13).Font.FontStyle = "gras" Cells(ls, 14).Font.FontStyle = "gras" End If Cells(ls, 2).Value = LigneTab(i, 2) 'Nom du fichier Cells(ls, 3).Value = LigneTab(i, 3) 'nombre adresses lues Cells(ls, 4).Value = LigneTab(i, 4) 'nombre adresses rejetees If LigneTab(i, 4) = "" And Cells(ls, 2).Value <> "" Then Cells(ls, 4).Value = 0 End If Cells(ls, 5).Value = LigneTab(i, 5) 'nombre adresses uniques '** calcul du pourcentage adresses uniques If Cells(ls, 2).Value <> "" Then pourc_uniques = (LigneTab(i, 5) / LigneTab(i, 3)) * 100 Cells(ls, 6).Value = pourc_uniques 'pourcentage adresses uniques End If Cells(ls, 7).Value = LigneTab(i, 6) 'nombre adresses repoussees '** calcul du pourcentage adresses repoussees If Cells(ls, 2).Value <> "" Then pourc_repous = (LigneTab(i, 6) / LigneTab(i, 3)) * 100 Cells(ls, 8).Value = pourc_repous 'pourcentage adresses repoussees End If Cells(ls, 9).Value = LigneTab(i, 7) 'nombre adresses 1er de groupe '** calcul du pourcentage adresses 1er de groupe If Cells(ls, 2).Value <> "" Then pourc_1grpe = (LigneTab(i, 7) / LigneTab(i, 3)) * 100 Cells(ls, 10).Value = pourc_1grpe 'pourcentage adresses 1er de groupe End If Cells(ls, 11).Value = LigneTab(i, 8) 'nombre adresses nieme de groupe '** calcul du pourcentage adresses nieme de groupe If Cells(ls, 11).Value <> "" Then pourc_ngrpe = (LigneTab(i, 8) / LigneTab(i, 3)) * 100 Cells(ls, 12).Value = pourc_ngrpe 'pourcentage adresses nieme de groupe End If Cells(ls, 13).Value = LigneTab(i, 9) 'nombre adresses a editer '** calcul du pourcentage adresses à editer If Cells(ls, 13).Value <> "" Then pourc_aediter = (LigneTab(i, 9) / LigneTab(i, 3)) * 100 Cells(ls, 14).Value = pourc_aediter 'pourcentage adresses a editer End If 'quadriage des cellules renseignées Do ' quadriage du tableau If (UCase(LigneTab(i, 2)) = "CUMUL" Or UCase(LigneTab(i, 2)) = "HORS REPOUSSOIR") And (Q = 1) Then Else If Cells(ls, Q).Value <> "" Then Cells(ls, Q).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End If End If Q = Q + 1 Loop Until Q > 14 '******************************************************** Else If UCase(LigneTab(i, 1)) = "ETAT04" Then 'ventilation des niemes Range("A1").Select colonne = LigneTab(i, 2) ActiveWorkbook.Sheets(5).Select h3 = h3 + 1 c3 = 2 t3 = 3 Cells(10, 3).Select ActiveWindow.FreezePanes = True 'figer une cellule Do If c3 = LigneTab(i, 2) Or (LigneTab(i, 3) = "") Then Cells(h3, c3).Font.FontStyle = "gras" End If Cells(h3, 2).Font.FontStyle = "gras" Cells(h3, c3).NumberFormat = "#,##0" 'format cellule nombre av 0 decimale et separateur de milliers Cells(h3, c3).HorizontalAlignment = xlCenter Cells(h3, c3).Value = LigneTab(i, t3) ' quadriage des cellules renseignées 'If Cells(h3, c3).Value <> "" And Cells(h3, c3).Value <> " " Then 'quadriage des champs renseignes If Cells(h3, c3).Value = "" And c3 = 2 Or Cells(h3, 2).Value = "" And h3 <> 9 Then Else If Cells(h3, c3).Value <> " " Then ' quadriage du tableau Cells(h3, c3).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End If End If t3 = t3 + 1 c3 = c3 + 1 Loop Until c3 > LigneTab(i, 2) - 1 End If End If End If End If End If 'les div par 100 sont mises pour compenser le formatage des cellules en % 'Range("F14").Value = LigneTab(6) / 100 'ordre des lignes modifiees 'Range("G26").Value = NBR_CHAMPS 'Nombre DE CHAMPS ecrits dans l enregistrement '''''Range("E30").Value = NOMBRE 'Nombre D ENREGISTREMENTS ecrits dans la table 'Range("G28").Value = NOMBRE_EXCEL 'Nombre D ENREGISTREMENTS ecrits dans EXCEL 'ActiveSheet.Name = NomOnglet 'Suppression du quadriage ' ActiveWindow.DisplayGridlines = False i = i + 1 Loop Until i > NOMBRE '**** Calcul Total Ligne Ventilation **************************** Dim rg As Range i = 10 Do If Cells(i, 2).Value <> "" Then Set rg = ActiveSheet.Range(Cells(i, 3), Cells(i, colonne - 1)) ActiveSheet.Cells(i, colonne).Formula = "=SUM(" & rg.AddressLocal & " )" 'total adresses ligne ventilation Cells(i, colonne).Font.FontStyle = "gras" Cells(i, colonne).NumberFormat = "#,##0" 'format cellule nombre av 0 decimale et separateur de milliers Cells(i, colonne).HorizontalAlignment = xlCenter End If 'quadriage des cellules renseignées If Cells(i, colonne).Value <> "" Then Cells(i, colonne).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End If i = i + 1 Loop Until i > h3 '**** Calcul Total Colonne Ventilation ************************ tventlig = 3 i = 3 Do Set rg = ActiveSheet.Range(Cells(10, tventlig), Cells(h3, tventlig)) ActiveSheet.Cells(h3 + 2, tventlig).Formula = "=SUM(" & rg.AddressLocal & " )" 'total adresses colonne ventilation Cells(h3 + 2, tventlig).Font.FontStyle = "gras" Cells(h3 + 2, tventlig).NumberFormat = "#,##0" 'format cellule nombre av 0 decimale et separateur de milliers Cells(h3 + 2, tventlig).HorizontalAlignment = xlCenter 'quadriage des cellules renseignées If Cells(h3 + 2, i).Value <> "" Then Cells(h3 + 2, i).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End If tventlig = tventlig + 1 i = i + 1 Loop Until i > colonne - 1 Range("A1").Select 'Suppression des feuilles créees automatiquement Application.DisplayAlerts = False i = 1 Do If UCase(Mid(ActiveWorkbook.Sheets(i).Name, 1, 5)) = "FEUIL" Then ActiveWorkbook.Sheets(i).Delete Else i = i + 1 End If Loop Until i > ActiveWorkbook.Sheets.Count 'fin suppression des feuilles créees automatiquement Worksheets(1).Select 'Ouvrir toujours sur la premiere feuille End Sub Sub RetrieveData() Dim Csv_in, Xls_out As String Dim Tmp_Classeur As Workbook Dim LgData As Range Dim TxtCsv_IN As String, ClassTrt As String, ClassClient As String Dim ClassFinal As String Dim i As Integer Dim j As Integer ' indice pour la ligne Dim ITAB As Integer ' indice pour la table Dim p As Variant Dim EcranMaj As Boolean XLMain = ActiveWorkbook.Name NomOnglet = ActiveSheet.Name TxtCsv_IN = Environ("RESULTO") ClassTrt = ExtractFileName(TxtCsv_IN) EcranMaj = Application.ScreenUpdating On Error GoTo ErrorHandler Application.ScreenUpdating = False OuvrirFichierXL TxtCsv_IN, ClassTrt, Erreur Workbooks(ClassTrt).Activate j = 2 ITAB = 1 Do 'Range("A2").EntireRow.Select Range("A" & j).EntireRow.Select i = 1 For Each p In Selection If i > 2000 Then 'If IsEmpty(p.Value) Then ' modif '**** supprimer pour les fichiers crées par talend 'If (p.value) is null ' bugge et permet d'afficher le fichier excel Exit For '**** separateurs consecutifs ;; et non ; ; dans stat ventilation End If LigneTab(ITAB, i) = p.Value i = i + 1 Next j = j + 1 ITAB = ITAB + 1 Loop Until j > ActiveSheet.UsedRange.Rows.Count 'Calcul du nombre dE CHAMPS ecrits dans un enregistrement NBR_CHAMPS = i - 1 'Calcul du nombre d ENREGISTREMENTS ecrits dans la table NOMBRE = ActiveSheet.UsedRange.Rows.Count - 1 NOMBRE_EXCEL = ActiveSheet.UsedRange.Rows.Count 'fermeture TxtCsv_IN ActiveWorkbook.Close False CopierValeurs ClassFinal EnregisterFermer ClassFinal, ClassTrt 'Environ("STATEVAO") Application.ScreenUpdating = EcranMaj Application.Quit Exit Sub ErrorHandler: 'MsgBox Erreur Application.ScreenUpdating = EcranMaj MsgBox Err.Description On Error GoTo 0 End Sub