'Option Explicit
Private Sub traitement()
Dim MonTab1 As Variant, Compt11 As Long, Plg1 As Range
Dim MonTab2 As Variant, Compt12 As Long, Plg2 As Range
Dim MonTab3 As Variant, Compt13 As Long, Plg3 As Range
Dim quoi$, z As String, Trouve As Boolean, Dl1 As Long
Feuil3.Cells.Delete 'j'efface la feuille transfere
With Sheets("REC_DIS") ' Feuil1 'Déclaration implicite de l'objet feuil1
Dl1 = .Range("A" & .Rows.Count).End(xlUp).Row
Set Plg1 = .Range("A2:N" & Dl1)
MonTab1 = Plg1.Value
End With
'Entête
With Sheets("DIS_Laval") ',Feuil4
.Cells(1, 1) = "Intervention": .Cells(1, 2) = "Conclusion": .Cells(1, 3) = "Code": .Cells(1, 4) = "Genre_Intervention": .Cells(1, 5) = "Statut": .Cells(1, 6) = "Date_début": .Cells(1, 7) = "Date_fin": .Cells(1, 8) = "Code_Inspecteur": .Cells(1, 9) = "Anomalie": .Cells(1, 10) = "Numero_demande": .Cells(1, 11) = "Date_Creation_Demande": .Cells(1, 12) = "Nom_Inspecteur": .Cells(1, 13) = "Prenom_Inspecteur": .Cells(1, 14) = "Domaine_Intervention"
.Rows(1).Font.Bold = True
Set Plg2 = .Range("A2:N" & Dl1)'les tableaux doivent avoir la même dimention
MonTab2 = Plg2.Value
End With
With Sheets("Liste_service")
Set Plg3 = .Range("c4:D" & .UsedRange.Rows.Count)
MonTab3 = Plg3.Value
For Compt11 = LBound(MonTab1, 1) To UBound(MonTab1, 1)
z = MonTab1(Compt11, 13) & Chr(32) & MonTab1(Compt11, 12) 'prénom nom
Trouve = False
For Compt13 = LBound(MonTab3, 1) To UBound(MonTab3, 1)
If MonTab3(Compt13, 1) = z Then
Trouve = True
Exit For
End If
Next Compt13
If Trouve = True Then
For i = 1 To 14
MonTab2(Compt11, i) = MonTab1(Compt11, i)
Next i
End If
Next Compt11
Plg2 = MonTab2
Suprimer2 "DIS_Laval"
'je cloture la déclaration implicite
With Sheets("DIS_Laval")
.Activate
.Columns("A:Y").AutoFit: .Range("A1").CurrentRegion.Borders.LineStyle = 1 'J'ajuste mes colonnes en tailles
End With
End Sub
'Procedure pour supprimer les lignes vides
Private Sub Suprimer2(Nomfeuille1 As String)
Dim Cel1 As Range, S1 As Worksheet, Li1 As Long, Li2 As Long
On Error GoTo Suprimer2_Error
Application.EnableEvents = False
If Nomfeuille1 <> "" Then
Set S1 = Worksheets(Nomfeuille1)
Set Cel1 = S1.Range("a:a").SpecialCells(xlCellTypeBlanks)
Cel1.EntireRow.Delete Shift:=xlUp
End If
On Error GoTo 0
Application.EnableEvents = True
Suprimer2_Error:
End Sub