Re,
Ouais, le problème vient de la macro qui envoi le PDF dans le fichier Excel
Teste
Sub Historique()
'DESACTIVER LA MISE A JOUR DE LA PAGE PENDANT LES CALCULS
Application.ScreenUpdating = False
' Tableau des recherches et substitutions
Dim Substitutions(6, 1) As String
Substitutions(0, 0) = "06"
Substitutions(0, 1) = "F mobile"
Substitutions(1, 0) = "06"
Substitutions(1, 1) = "MJ mobile"
Substitutions(2, 0) = "06"
Substitutions(2, 1) = "C mobile"
Substitutions(3, 0) = "05"
Substitutions(3, 1) = "F&MJ fixe"
Substitutions(4, 0) = "05"
Substitutions(4, 1) = "C fixe"
Substitutions(5, 0) = "06"
Substitutions(5, 1) = "C mobile"
Substitutions(6, 0) = "05"
Substitutions(6, 1) = "D & C fixe"
' Vérifier la valeur de la cellule A1 et effectuer les substitutions dans les cellules de la colonne H si la chaîne de caractères est trouvée
Dim lastRow As Long
Dim i As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 0 To UBound(Substitutions, 1)
If InStr(Range("A1").Value, Substitutions(j, 0)) > 0 Then
For i = 3 To lastRow
If Not Range("A" & i).EntireRow.Hidden Then
Range("H" & i).Value = Substitutions(j, 1)
Debug.Print "Ecriture dans H" & i
End If
Next i
End If
Next j
'Activer le filtre de données sur la ligne 2
Range("2:2").AutoFilter
Dim cel As Range
Dim heures As Integer
Dim minutes As Integer
Dim secondes As Integer
Dim temps As String
Dim temps_converti As String
Dim wb As Workbook
Dim ws As Worksheet
Dim derniereLigne As Long
Dim nomfichier As String
Dim rng As Range
'Dim i As Long
Dim valeurs As Variant
Dim chemin As String
chemin = ActiveWorkbook.Path & "\"
'Renommer l'onglet courant
ActiveSheet.Name = "Suivi_conso"
'Vérification de la feuille de calcul, avec ou sans titre "Type" dans la cellule A2
If Range("A2").Value <> "Type" Then 'Vérifie si la cellule A2 est différente de "Type"
Columns("A").Insert Shift:=xlToRight 'Insère une colonne à gauche de la colonne A
Range("A2").Value = "Type" 'Ecrit "Type" dans la cellule A2
End If
'Sélectionne la plage de cellules à partir de A1
Range("A1:G1").Select
'Supprime la fusion des cellules
Selection.UnMerge
'A partir de A3, supprime les lignes contenant le texte "Type"
'Détermine le numéro de la dernière ligne avec des données dans la colonne A
lastRow = Range("A" & Rows.Count).End(xlUp).Row
'Boucle sur chaque ligne de la colonne A à partir de la ligne 3
For i = 3 To lastRow
'Vérifie si la cellule de la colonne A contient le texte "Type"
If Range("A" & i).Value = "Type" Then
'Supprime la ligne correspondante
Rows(i).Delete
'Décrémente le compteur de boucle pour compenser la suppression de la ligne
i = i - 1
'Réduit le numéro de la dernière ligne car une ligne a été supprimée
lastRow = lastRow - 1
End If
Next i
'Enregistrer le fichier converti et conserver l'ancien fichier dans le même répertoire courant
Dim ancienNom As String
Dim nouveauNom As String
Dim cheminComplet As String 'Variable pour stocker le chemin complet du fichier actif
ancienNom = ActiveWorkbook.Name 'Nom du fichier courant
chemin = ActiveWorkbook.Path & "\" 'Chemin d'accès complet au répertoire courant
'Enregistrer le chemin complet du fichier actif
cheminComplet = ActiveWorkbook.FullName
'Remplacement de "h" par"h " ou "min" par "min "
Dim cell As Range
'Parcourir chaque cellule de la colonne E à partir de la 3ème ligne
For Each cell In Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row)
'Rechercher "h" et le remplacer par "h "
cell.Value = Replace(cell.Value, "h", "h ")
'Rechercher "min" et le remplacer par "min "
cell.Value = Replace(cell.Value, "min", "min ")
'Rechercher "min " et le remplacer par "min "
cell.Value = Replace(cell.Value, "min ", "min ")
Next cell
'Conversion des cellules à partir de E3
Set rng = Range("E3", Range("E" & Rows.Count).End(xlUp))
For i = 1 To rng.Rows.Count
valeurs = Split(rng.Cells(i).Value, " ")
heures = 0
minutes = 0
secondes = 0
For j = 0 To UBound(valeurs)
If InStr(valeurs(j), "h") > 0 Then
heures = Val(Left(valeurs(j), Len(valeurs(j)) - 1))
ElseIf InStr(valeurs(j), "min") > 0 Then
minutes = Val(Left(valeurs(j), Len(valeurs(j)) - 3))
ElseIf InStr(valeurs(j), "s") > 0 Then
secondes = Val(Left(valeurs(j), Len(valeurs(j)) - 1))
End If
Next j
'Inscrire le résultat de la conversion avec un offset de 2 colonnes soit de E à G
rng.Cells(i).Offset(0, 2).Value = Format(TimeSerial(heures, minutes, secondes), "hh:mm:ss")
Next i
'Cellule G2 format personnalisé hh:mm:ss
Range("G2").NumberFormat = "hh:mm:ss"
'Changement de police de caractère
With Range("A1:I" & Range("A" & Rows.Count).End(xlUp).Row)
.Font.Name = "Arial"
.Font.Size = 11
End With
'Activation de la fonction texte gras, alignement centré et fond gris des cellules A1 à I2
With Range("A1:I2")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Interior.Color = RGB(192, 192, 192)
End With
'Activation de la fonction Retour à la ligne automatique pour les lignes à partir de la ligne 2
Range("A2:G" & Range("A" & Rows.Count).End(xlUp).Row).WrapText = False
'Police de caractère gras et centrée pour les lignes 1 et 2
Range("1:2").Font.Bold = True
Range("1:2").HorizontalAlignment = xlCenter
'Positionnement de la fonction Données-Filtrer pour la ligne 2
Range("2:2").Select
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
Else
Selection.AutoFilter
End If
'Cellule G2 format personnalisé hh:mm:ss
Range("G2").NumberFormat = "hh:mm:ss"
Range("A3").Select
ActiveWindow.FreezePanes = True
'Mise en forme de la colonne G et H
Range("G1:H2").Interior.Color = RGB(192, 192, 192) 'Fond gris
Range("G1:H2").Font.Bold = True 'Police en gras
Range("G1").Value = "Volume HH:MM:SS" 'Titre en G1
Range("H1").Value = "QUI" 'Titre en H1
Range("H2").Value = "Appelle" 'Titre en H2
Range("I1").Value = "QUI" 'Titre en I1
Range("I2").Value = "Est appelé" 'Titre en I2
'Remplacer " à " par " " dans la colonne B
Columns("B:B").Replace " à ", " ", xlPart
' Appliquer le format personnalisé "jj/mm/aaaa hh:mm:ss" aux cellules non vides de la colonne B
'Application.ScreenUpdating = False
'Supprimer la ligne contenant le texte "Date"
'Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).row).Find("Date", LookIn:=xlValues, LookAt:=xlWhole).EntireRow.Delete
'Formater la date en JJ/MM/AAAA HH:MM
Set rng = Range("B3:B" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each cel In rng
If cel.Value <> "" Then
cel.Value = CDate(Format(cel.Value, "mm/dd/yyyy hh:mm"))
End If
Next cel
'Application.ScreenUpdating = True
'Activation de la fonction Retour à la ligne automatique et fusion des cellules A1 à D1
With Range("A1:D1")
.Merge
.WrapText = True
End With
'Hauteur de ligne 1 35 points
Rows("1").RowHeight = 35
'Sélectionner toutes les cellules jusqu'à la dernière cellule non vide
Dim lastCol As Long
lastRow = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 'Trouve le numéro de la dernière ligne non vide
lastCol = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column 'Trouve le numéro de la dernière colonne non vide
Range(Cells(1, 1), Cells(lastRow, lastCol)).Select 'Sélectionne toutes les cellules de la feuille active jusqu'à la dernière cellule non vide
' Parcourir toutes les cellules non vides et activer les quadrillages
For Each cell In ActiveSheet.UsedRange.Cells
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
.LineStyle = xlContinuous
.Item(xlEdgeTop).LineStyle = xlContinuous
.Item(xlEdgeBottom).LineStyle = xlContinuous
End With
Next cell
'Ajustement de la largeur des colonnes et des lignes
Cells.EntireColumn.HorizontalAlignment = xlCenter
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
'MACRO AVEC AJOUT DE LA FEUILLE DE CALCUL Repertoire_Telephone
'Définition du chemin d'accès et du nom du fichier
chemin = ActiveWorkbook.Path & "\"
nomfichier = ActiveWorkbook.Name
'Extraction de la date de création du fichier d'origine
dateFichier = Format(FileDateTime(chemin & nomfichier), "yyyy-mm-dd")
'Création du nouveau nom de fichier avec la date de création en préfixe
extension = Right(nomfichier, Len(nomfichier) - InStrRev(nomfichier, "."))
nouveauNom = dateFichier & " " & Left(nomfichier, InStrRev(nomfichier, ".") - 1)
'Enregistrement du fichier csv en format xlsx avec un nouveau nom dans le répertoire courant
Workbooks.Open Filename:=chemin & nomfichier
ActiveWorkbook.SaveAs Filename:=chemin & nouveauNom & ".xlsx", FileFormat:=xlOpenXMLWorkbook
'RAJOUTER UNE COLONNE H CONTENANT LE NOM DE L'APPELANT
Set rng = Range("A1") 'La cellule A1 est vérifiée
If rng.Value Like "06" Then
'Ajouter une colonne H et écrire "F mobile"
Sheets(1).Columns("H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Value = "F mobile"
ElseIf rng.Value Like "06" Then
'Ajouter une colonne H et écrire "MJ mobile mobile"
Sheets(1).Columns("H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Value = "MJ mobile mobile"
ElseIf rng.Value Like "06 " Then
'Ajouter une colonne H et écrire "Cmobile"
Sheets(1).Columns("H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Value = "C mobile"
If rng.Value Like "05" Then
'Ajouter une colonne H et écrire "C fixe"
Sheets(1).Columns("H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Value = "C fixe"
ElseIf rng.Value Like "06" Then
'Ajouter une colonne H et écrire "Cmobile"
Sheets(1).Columns("H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Value = "C mobile"
ElseIf rng.Value Like "05" Then
'Ajouter une colonne H et écrire "C fixe"
Sheets(1).Columns("H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Value = "C fixe"
End If
End If
'RAJOUTER LA FEUILLE DE CALCUL "Repertoire_Telephone"
' Déclaration des variables
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim password As String
' Chemin d'accès et nom du fichier source de la feuille à rajouter
Dim sourcePath As String
sourcePath = "\\DISKSTATION\home\Dossiers communs\Téléphone\Repertoire_telephonique\Repertoire_Telephone.xlsx"
' Nom de la feuille de calcul source
Dim sourceSheetName As String
sourceSheetName = "Répertoire"
' Référence au classeur actif dans lequel rajouter la feuille de calcul
Set wb = ActiveWorkbook
' Ouverture du fichier source
Set wbSource = Workbooks.Open(Filename:=sourcePath, password:=password)
' Référence à la feuille de calcul à ajouter
Set wsSource = wbSource.Worksheets(sourceSheetName)
' Copie de la feuille de calcul source vers le classeur actif
wsSource.Copy After:=wb.Sheets(wb.Sheets.Count)
' Fermeture du fichier source
wbSource.Close False
'Enregistrer le fichier converti et conserver l'ancien fichier dans le même répertoire courant
ancienNom = ActiveWorkbook.Name 'Nom du fichier courant
chemin = ActiveWorkbook.Path & "\" 'Chemin d'accès complet au répertoire courant
'Enregistrer le chemin complet du fichier actif
cheminComplet = ActiveWorkbook.FullName
'Finir en sélectionnant la cellule A3
Range("A2").Select ' Sélectionne la cellule A2 du premier onglet
Sheets(1).Select ' Sélectionne le premier onglet
Range("A3").Select ' Sélectionne la cellule A3 du premier onglet
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim lookupValue As Variant
Dim lookupRange As Range
Dim lookupResult As Variant
'Obtenir la dernière ligne de la colonne C de la Feuille1 "Suivi_conso"
lastRow1 = Sheets("Suivi_conso").Cells(Rows.Count, "C").End(xlUp).Row
'Obtenir la dernière ligne de la colonne D de la Feuille2 "Répertoire"
lastRow2 = Sheets("Répertoire").Cells(Rows.Count, "D").End(xlUp).Row
'Définir la plage de recherche dans la colonne C de la Feuille2 "Répertoire"
Set lookupRange = Sheets("Répertoire").Range("C1:C" & lastRow2)
'Boucler sur chaque ligne de la colonne C de la Feuille1 "Suivi_conso"
For i = 1 To lastRow1
'Obtenir la valeur de la cellule C de la Feuille1 "Suivi_conso"
lookupValue = Sheets("Suivi_conso").Range("C" & i).Value
'Utiliser la fonction INDEX/MATCH pour chercher la valeur dans la colonne C de la Feuille2 "Répertoire"
lookupResult = Application.Index(Sheets("Répertoire").Range("C1:C" & lastRow2), Application.Match(lookupValue, Sheets("Répertoire").Range("D1:D" & lastRow2), 0))
'Ecrire le résultat dans la cellule I3 de la Feuille1 "Suivi_conso"
Sheets("Suivi_conso").Range("I3").Offset(i - 3, 0).Value = lookupResult
Next i
'Renommer les cellules I1 et I2
Range("I1").Value = "QUI" 'Titre en I1
Range("I2").Value = "Est appelé" 'Titre en I2
'Ajustement de la largeur des colonnes et des lignes
Cells.EntireColumn.HorizontalAlignment = xlCenter
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
'FILTRER LA LIGNE 2
'Sélectionne la ligne 2
Range("A2").Select
'Sélectionne la ligne 2
Rows("2:2").Select
'Active le filtre automatique
Selection.AutoFilter
'Finir en sélectionnant la cellule A3
Range("A3").Select
'Enregistrer et fermer le fichier finalisé
ActiveWorkbook.Save
'REACTIVER LA MISE A JOUR DE LA PAGE A LA FIN DES CALCULS
Application.ScreenUpdating = True
' affichage du message "Fin de traitement"
MsgBox "Fin de traitement"
ActiveWorkbook.Close
End Sub
