Recopier des valeurs du classeur1 dans classeur2

Bonjour à tous,

J’aimerais recopier les valeurs Bx:Fx du classeur1 dans la colonne du moi=
s passé du classeur2.

Pour le moment, j’ai une erreur pour ouvrir le classeur2 (LHCF.xls)

Le résultat voulu est dans feuil2 du classeur2.

'--
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$

Set WB1 = Workbooks("TQ (1).xls")
Set WB2 = Workbooks.Open("LHCF.xls")

'-- 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).En=
d(xlUp) _
.Offset(1, 0)) ' Pour faire en=
trer 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, LookA=
t:=xlPart)
If Not fObj Is Nothing Then
'-- Si l'objet trouvé se termine par un D
'-- On commence l'écriture juste à la ligne de fnOb=
j dans classeur2
Chn = WB1.Sheets("feuil1").Range("A" & fObj.Row)

If Mid(Chn, Len(Chn), 1) = "D" Then
WB2.Sheets("feuil1").Cells(fnObj.Row, fMonth.Column=
).Resize(4, 1).Value = Application.Transpose(WB1.Sheets("feuil1").Range(C=
ells(fObj.Row, 2), Cells(fObj.Row, 7)).Value)

'-- 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
WB2.Sheets("feuil1").Cells(fnObj.Row + 8, fMonth.Co=
lumn).Resize(4, 1).Value = Application.Transpose(WB1.Sheets("feuil1").Ran=
ge(Cells(fObj.Row, 2), Cells(fObj.Row, 7)).Value)
End If
End If
End If
End If
Next i
Set WB1 = Nothing: Set WB2 = Nothing: Set mPlg = Nothing
Set obnPlg = Nothing: Set fnObj = Nothing: Set obPlg = Nothing: S=
et fObj = Nothing
End Sub
'-

[url]http://cjoint.com/?BFkx5djmCqV[/url]

Merci d'avance.

---

• Partager ce contenu :