1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
| Sub SansDoublons()
Const Entete = 1: Const Decal = 1
'Const Entete2 = 1: Const Decal2 = 1
Dim NomCl As String, Feuille As String, DL2 As Long, NbColC2 As Integer, Rng As Range
Dim DL1 As Long, NbColC1 As Integer, ThWb_Rng As Range, Col As String, Crit As Integer
Application.ScreenUpdating = False
Range("Tableau2[#All]").Select
Selection.Copy
Sheets("Actualisation du PDF°").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Actualisation du PDF°").Activate
Range("a1").Select
With Workbooks("Fichier 2 Du Personnel 2017").Sheets("Personnel") 'ThisWorkbook.Sheets("Feuil2")
NomCl = .Parent.Name: Feuille = .Name
DL2 = .Cells(Rows.Count, 6).End(xlUp).Row: NbColC2 = .UsedRange.Columns.Count
Set Rng = .Range(.Cells(Entete + 1, NbColC2 + Decal), .Cells(DL2, NbColC2 + Decal))
Rng.Formula = "=D" & Entete + 1 & "&""_""&H" & Entete + 1
End With
With ThisWorkbook.Sheets("Actualisation du PDF°")
DL1 = .Cells(Rows.Count, 1).End(xlUp).Row: NbColC1 = .UsedRange.Columns.Count
Crit = NbColC1 + Decal + 1
Set ThWb_Rng = .Range(.Cells(Entete + 1, NbColC1 + Decal), .Cells(DL1, NbColC1 + Decal))
ThWb_Rng.Formula = "=F" & Entete + 1 & "&""_""&B" & Entete + 1
Col = Split(ThWb_Rng.Address, "$")(1)
ThWb_Rng.Offset(, 1).Formula = "=MATCH(" & Col & Entete + 1 & ",[" & NomCl & "]" & Feuille & "!" & Rng.Address & ",0)"
If Application.CountIf(ThWb_Rng.Offset(, 1), "#N/A") > 0 Then
.UsedRange.AutoFilter Field:=Crit, Criteria1:="#N/A"
'.ListObjects("Tableau2").Range.AutoFilter Field:=Crit, Criteria1:="#N/A"
.Range("B" & Entete + 1 & ":B" & DL1).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Rng.Resize(1).Offset(Rng.Rows.Count, 8 - NbColC2 - Decal)
.Range("F" & Entete + 1 & ":F" & DL1).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Rng.Resize(1).Offset(Rng.Rows.Count, 4 - NbColC2 - Decal)
.Range("C" & Entete + 1 & ":C" & DL1).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Rng.Resize(1).Offset(Rng.Rows.Count, 5 - NbColC2 - Decal)
.Range("D" & Entete + 1 & ":D" & DL1).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Rng.Resize(1).Offset(Rng.Rows.Count, 6 - NbColC2 - Decal)
.Range("E" & Entete + 1 & ":E" & DL1).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Rng.Resize(1).Offset(Rng.Rows.Count, 7 - NbColC2 - Decal)
If .AutoFilterMode Then .Cells.AutoFilter
Else
MsgBox "Aucun champs uniques à ajouter"
End If
ThWb_Rng.Resize(, 2).Clear
End With
Rng.Clear: Set Rng = Nothing: Set ThWb_Rng = Nothing
Application.ScreenUpdating = True
End Sub |
Partager