Option Base 1
Sub Macro_MAJ()
Dim Sh As Worksheet
Dim i As Integer
Dim oComposant As VBComponent
Dim sNomModule As String, LigneTitre As String
Dim Derligne_cible As Integer
Dim Derligne_source As Integer
Dim Onglet_source_existe As Boolean
Dim Filtre_actif As Boolean
Dim Chemin_Fichier_source As String
Dim Fichier_source As String
Dim Fichier_cible As String 'ce fichier
Dim Onglet_cible As String
Dim Onglet_source As String
Dim Ligne_SP As String
Dim Max_SP As String
Dim Tab_correspondance_colonne(72) As Integer
Application.ScreenUpdating = False ' arret affichage
' Efface les N° de Parts
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
'Paramètrage des noms de fichiers
Fichier_cible = "Non_du_fichier_1.xlsm"
Chemin_Fichier_source = "Chemin du fichier source c:\\ ou http://"
Fichier_source = "Non_du_fichier_2.xlsm"
Onglet_cible = "Onglet_du_fichier_1"
Onglet_source = "Onglet_du_fichier_1"
'tableau de correspondance des colonne entre les 2 fichier
' Colonne cible = Colonne source Lettre colonne cible
Tab_correspondance_colonne(1) = 1 'A
Tab_correspondance_colonne(2) = 2 'B
Tab_correspondance_colonne(3) = 3 'C
Tab_correspondance_colonne(4) = 4 'D
Tab_correspondance_colonne(5) = 5 'E
Tab_correspondance_colonne(6) = 6 'F
Tab_correspondance_colonne(7) = 7 'G
Tab_correspondance_colonne(8) = 8 'H
Tab_correspondance_colonne(9) = 9 'I
Tab_correspondance_colonne(10) = 10 'J
Tab_correspondance_colonne(11) = 11 'K
Tab_correspondance_colonne(12) = 12 'L
Tab_correspondance_colonne(13) = 13 'M
Tab_correspondance_colonne(14) = 14 'N
Tab_correspondance_colonne(15) = 15 'O
Tab_correspondance_colonne(16) = 16 'P
Tab_correspondance_colonne(17) = 17 'Q
Tab_correspondance_colonne(18) = 18 'R
Tab_correspondance_colonne(19) = 19 'S
Tab_correspondance_colonne(20) = 20 'T
Tab_correspondance_colonne(21) = 21 'U
Tab_correspondance_colonne(22) = 22 'V
Tab_correspondance_colonne(23) = 23 'W
Tab_correspondance_colonne(24) = 24 'X
Tab_correspondance_colonne(25) = 25 'Y
Tab_correspondance_colonne(26) = 26 'Z
Tab_correspondance_colonne(27) = 27 'AA
Tab_correspondance_colonne(28) = 28 'AB
Tab_correspondance_colonne(29) = 29 'AC
Tab_correspondance_colonne(30) = 30 'AD
Tab_correspondance_colonne(31) = 31 'AE
Tab_correspondance_colonne(32) = 32 'AF
Tab_correspondance_colonne(33) = 33 'AG
Tab_correspondance_colonne(34) = 34 'AH
Tab_correspondance_colonne(35) = 35 'AI
Tab_correspondance_colonne(36) = 36 'AJ
Tab_correspondance_colonne(37) = 37 'AK
Tab_correspondance_colonne(38) = 38 'AL
Tab_correspondance_colonne(39) = 39 'AM
Tab_correspondance_colonne(40) = 40 'AN
Tab_correspondance_colonne(41) = 41 'AO
Tab_correspondance_colonne(42) = 42 'AP
Tab_correspondance_colonne(43) = 43 'AQ
Tab_correspondance_colonne(44) = 44 'AR
Tab_correspondance_colonne(45) = 45 'AS
Tab_correspondance_colonne(46) = 46 'AT
Tab_correspondance_colonne(47) = 47 'AU
Tab_correspondance_colonne(48) = 48 'AV
Tab_correspondance_colonne(49) = 49 'AW
Tab_correspondance_colonne(50) = 50 'AX
Tab_correspondance_colonne(51) = 51 'AY
Tab_correspondance_colonne(52) = 52 'AZ
Tab_correspondance_colonne(53) = 53 'BA
Tab_correspondance_colonne(54) = 54 'BB
Tab_correspondance_colonne(55) = 55 'BC
Tab_correspondance_colonne(56) = 56 'BD
Tab_correspondance_colonne(57) = 57 'BE
Tab_correspondance_colonne(58) = 58 'BF
Tab_correspondance_colonne(59) = 59 'BG
Tab_correspondance_colonne(60) = 60 'BH
Tab_correspondance_colonne(61) = 61 'BI
Tab_correspondance_colonne(62) = 62 'BJ
Tab_correspondance_colonne(63) = 63 'BK
Tab_correspondance_colonne(64) = 64 'BL
Tab_correspondance_colonne(65) = 65 'BM
Tab_correspondance_colonne(66) = 66 'BN
Tab_correspondance_colonne(67) = 67 'BO
Tab_correspondance_colonne(68) = 68 'BP
Tab_correspondance_colonne(69) = 69 'BQ
Tab_correspondance_colonne(70) = 70 'BR
Tab_correspondance_colonne(71) = 71 'BS
Tab_correspondance_colonne(72) = 72 'BT
Onglet_source_existe = False
'recherche si l'onglet source n'existe pas dans le fichier
For Each Sh In Worksheets
If Sh.Name = Onglet_source Then
Onglet_source_existe = True
Exit For
End If
Next Sh
If Onglet_source_existe = False Then
'ouverture du fichier source
If Test_fichier_ouvert(Fichier_source) = False Then
Workbooks.Open Chemin_Fichier_source
End If
'copie de l'onglet utilisé pour éviter les aller retour entre les 2 fichiers
Windows(Fichier_source).Activate
Sheets(Onglet_source).Select
Sheets(Onglet_source).Copy After:=Workbooks(Fichier_cible).Sheets(1)
'fermeture du fichier source
Application.DisplayAlerts = False
Windows(Fichier_source).Close
Application.DisplayAlerts = True
End If
'vérrification d'existance du filtre
If ActiveSheet.FilterMode Then
'supression des filtres sur la source
Sheets(Onglet_source).Select
ActiveSheet.ShowAllData
End If
' Supression des fonctions (macro) de la feuille
For Each oComposant In ActiveWorkbook.VBProject.VBComponents
sNomModule = oComposant.Name
If oComposant.Type = vbext_ct_ClassModule Or vbext_ct_StdModule Or vbext_ct_MSForm Then
With oComposant.CodeModule
.DeleteLines 1, .CountOfLines
End With
End If
Next oComposant
'Filtre sur le service
ActiveSheet.Range("$A$3:$BU$1000").AutoFilter Field:=10, Criteria1:= _
"choix du service"
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
' Colle les N° de Parts ciblée
Sheets(Onglet_cible).Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B3").Select
Application.ScreenUpdating = False ' arret affichage
' Retour à l'onglet source
Sheets(Onglet_source).Select
Range("A3").Select
' compte les lignes à traiter
Derligne_cible = Worksheets(Onglet_cible).Range("A36000").End(xlUp).Row
Derligne_source = Worksheets(Onglet_source).Range("A36000").End(xlUp).Row
' Recopie le nombre 3 selules indépendantes
Worksheets(Onglet_cible).Cells(1, 1).Value = Worksheets(Onglet_source).Cells(1, 1).Value
Worksheets(Onglet_cible).Cells(2, 1).Value = Worksheets(Onglet_source).Cells(2, 1).Value
Worksheets(Onglet_cible).Cells(1, 58).Value = Worksheets(Onglet_source).Cells(1, 58).Value
' Traitement des données de correspondance
For i = 3 To Derligne_cible
If IsNumeric(Worksheets(Onglet_cible).Cells(i, 1).Value) = True Then
For j = 5 To Derligne_source
If Worksheets(Onglet_source).Cells(j, 1).Value = Worksheets(Onglet_cible).Cells(i, 1).Value Then
For k = 1 To UBound(Tab_correspondance_colonne)
If Tab_correspondance_colonne(k) <> 0 Then
If Worksheets(Onglet_cible).Cells(i, k).Value <> Worksheets(Onglet_source).Cells(j, Tab_correspondance_colonne(k)).Value Then
Worksheets(Onglet_cible).Activate
Worksheets(Onglet_cible).Cells(i, k).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Worksheets(Onglet_cible).Cells(i, k).Value = Worksheets(Onglet_source).Cells(j, Tab_correspondance_colonne(k)).Value
Else
Worksheets(Onglet_cible).Activate
Worksheets(Onglet_cible).Cells(i, k).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
Next k
Exit For
End If
Next j
End If
Next i
If Onglet_source_existe = False Then
'supression de l'onglet source
Application.DisplayAlerts = False
Sheets(Onglet_source).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End If
Sheets(Onglet_cible).Select
Range("A3").Select
' parametrage de l'impression
With Sheets(Onglet_cible)
.PageSetup.PrintArea = "$A$1:$BK$" & .[A4990].End(xlUp).Row
End With
Range("BU:XFD").EntireColumn.Hidden = True ' Cacher Collone (True=Oui, False=non)
Derligne = Worksheets(Onglet_cible).Range("A600").End(xlUp)(20).Row
Rows(Derligne & ":5040").EntireRow.Hidden = True ' Cacher Collone (True=Oui, False=non)
Application.ScreenUpdating = False ' affichage
End Sub
Function Test_fichier_ouvert(adresse As String) As Boolean
Test_fichier_ouvert = False
For Each fich In Workbooks
If fich.Name = adresse Then
Test_fichier_ouvert = True
Exit For
End If
Next
End Function