Sub Extract()
Dim WB1 As Workbook, WB2 As Workbook
Dim fMonth As Range, mPlg As Range, mF$
Dim obnPlg As Range, fnObj As Range, obPlg As Range, fObj As Range
Dim tb() As Variant, i%, Chn$
Dim fichier$
Dim plage As Range, c As Range
Dim fRw As Long, fnRw As Long
Application.ScreenUpdating = False
Set WB1 = ThisWorkbook
'-- Activer le fichier ==> sinon l'ouvrir
On Error Resume Next
Set WB2 = Workbooks("LHCF.xls")
If Err <> 0 Then
Err.Clear
fichier = "F:\MonRep\Excel\TF\LHCF.xls"
Set WB2 = Workbooks.Open(fichier)
If Err <> 0 Then
MsgBox "Le fichier '" & fichier & "' est introuvable"
End If
End If
'-- Mois passé
mF = Format(DateAdd("m", -1, Date), "mmm")
With WB1.Sheets("feuil1")
'-- Tableaux contenant les noms (Col H) et leurs équivalences en objet (Col I)
tb = .Range("H2:I" & [H65000].End(xlUp).Row).Value
'-- Plage des objets dans classeur1
Set obPlg = .Range(.Cells(2, 1), .Cells(.Cells.Rows.Count, 1).End(xlUp))
End With
With WB2.Sheets("feuil1")
'-- Plage des noms des objets dans classeur2
Set obnPlg = .Range(.Cells(9, 1), .Cells(.Cells.Rows.Count, 1).End(xlUp) _
.Offset(1, 0)) ' Pour faire entrer la derniere cellule fusionnée
'-- Plage des mois dans classeur2
Set mPlg = .Range(.Cells(7, 1), .Cells(7, 256).End(xlToLeft))
End With
'-- Recherche du mois passé
Set fMonth = mPlg.Find(mF)
For i = LBound(tb) To UBound(tb)
If Len(tb(i, 1)) > 0 Then
Set fnObj = obnPlg.Find(tb(i, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not fnObj Is Nothing Then
Set fObj = obPlg.Find(tb(i, 2), LookIn:=xlValues, LookAt:=xlPart)
If Not fObj Is Nothing Then
Chn = WB1.Sheets("feuil1").Range("A" & fObj.Row)
fRw = fObj.Row: fnRw = fnObj.Row
'-- Si l'objet trouvé se termine par un D
'-- On commence l'écriture juste à la ligne de fnObj dans classeur2
If Mid(Chn, Len(Chn), 1) = "D" Then
Set plage = WB2.Sheets(1).Cells(fnRw, fMonth.Column).Resize(5, 1)
'-- Copier les 5 valeurs de l'objet dans WB2 depuis WB1
WB1.Sheets(1).Range("B" & fRw & ":F" & fRw).Copy
plage.PasteSpecial Paste:=xlValues, Transpose:=True
Application.CutCopyMode = False
'-- Si les QS ou QT d'un objet sont nulles ou vides, alors mettre
'-- les NCS=0, TRF=0.00, QS=0.00, QT=0.00
With WB1.Sheets("feuil1")
If .Range("E" & fRw) = 0 Or .Range("F" & fRw) = "" Then _
WB2.Sheets("feuil1").Cells(fnRw + 1, fMonth.Column).Resize(4, 1).Value = 0
End With
'-- Formater les deux dernières valeurs en 0.00
For Each c In WB2.Sheets(1).Cells(fnRw + 3, fMonth.Column).Resize(2) 'plage
c = c * 100
c.NumberFormat = "0.00"
Next
'-- Si l'objet trouvé se termine par un A
'-- On commence l'écriture à la ligne de fnObj + 8 lignes en bas dans classeur2
ElseIf Mid(Chn, Len(Chn), 1) = "A" Then
Set plage = WB2.Sheets(1).Cells(fnRw + 8, fMonth.Column).Resize(5, 1)
'-- Copier les 5 valeurs de l'objet dans WB2 depuis WB1
WB1.Sheets(1).Range("B" & fRw & ":F" & fRw).Copy
plage.PasteSpecial Paste:=xlValues, Transpose:=True
Application.CutCopyMode = False
'-- Si les QS ou QT d'un objet sont nulles ou vides, alors mettre
'-- les NCS=0, TRF=0.00, QS=0.00, QT=0.00
With WB1.Sheets("feuil1")
If .Range("E" & fRw) = 0 Or .Range("F" & fRw) = "" Then _
WB2.Sheets("feuil1").Cells(fnRw + 9, fMonth.Column).Resize(4, 1).Value = 0
End With
'-- Formater les deux dernières valeurs en 0.00
For Each c In WB2.Sheets(1).Cells(fnRw + 11, fMonth.Column).Resize(2) 'plage
c = c * 100
c.NumberFormat = "0.00"
Next
End If
End If
End If
End If
Next i
Set WB1 = Nothing: Set WB2 = Nothing: Set mPlg = Nothing: Set plage = Nothing
Set obnPlg = Nothing: Set fnObj = Nothing: Set obPlg = Nothing: Set fObj = Nothing
Application.ScreenUpdating = True
End Sub
