Recopier des valeurs du classeur1 dans classeur2
Le
Apitos

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.
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.
Le lien n'est pas disponible.
Daniel
Le voila à nouveau :
http://cjoint.com/?BFkx5djmCqV
moins que tu sois absolument sûr que le classeur se trouve dans le
répertoire courant :
Set WB2 = Workbooks.Open("c:tempLHCF.xls")
par exemple au lieu de :
Set WB2 = Workbooks.Open("LHCF.xls")
Quel est ton message d'erreur ?
Daniel
J'ai ajouté un code de vérification à l'ouverture :
On Error Resume Next
Set WB2 = Workbooks("LHCF.xls") '.Activate
If Err <> 0 Then
Err.Clear
fichier = "F:MonRepExcelTFLHCF.xls"
Set WB2 = Workbooks.Open(fichier)
If Err <> 0 Then
MsgBox "Le fichier '" & fichier & "' est introuvable"
End If
End If
et ça marche pour le momemnt.
Maintenant j'ai une erreur dans cette ligne (rectifier):
WB2.Sheets("feuil1").Cells(fnObj.Row, fMonth.Column).Resize(5, 1).Value = Application.Transpose(WB1.Sheets("feuil1").Range(Cells(fObj.Row, 2), Cells (fObj.Row, 6)).Value)
Daniel
Maintenant je n'ai pas d'erreur. Bizarre !!?
Pourtant je n'ai rien fait ....
Bon, maintenant les valeurs sont recopiées, mais il y a un problème dan s le format d'écriture.
Par exemple, au lieu d'avoir :
- 44,70 j'ai 0.44
- 87,33 j'ai 0.87
Et puis j'aimerais ajouter un traitement sur les valeurs vides ou qui ont u n 0.
Pour n'importe quel objet qui a un QS ou QT égal à 0.00% ou vide, on do it rendre son NCS=0 et TRF=0
Ou bien une autre solution, collecter tous les objets qui ont un QS ou QT =0.00% ou QS ou QT vide pour, une fois rencontrer ces objets dans la bouc le, mettre des zéros pour les quatre valeurs : NCS, TRF, QS et QT.
Merci.
L'écriture se fait à quel niveau dans la macro ? quel est le format de
la cellule ?
Daniel
'-------------------
If Mid(Chn, Len(Chn), 1) = "D" Then
If Range("E" & fObj.Row) = 0 Or Range("E" & fObj. Row) = "" Or _
Range("F" & fObj.Row) = 0 Or Range("F" & fObj. Row) = "" Then _
Range("C" & fObj.Row) = 0: Range("D" & fObj.Ro w) = 0: Range("E" & fObj.Row) = 0: Range("F" & fObj.Row) = 0
WB2.Sheets("feuil1").Cells(fnObj.Row, fMonth.Column ).Resize(5, 1).Value = Application.Transpose(WB1.Sheets("feuil1").Range(C ells(fObj.Row, 2), Cells(fObj.Row, 6)).Value)
WB2.Sheets("feuil1").Cells(fnObj + 12, fMonth.Colum n).NumberFormat = "0.00"
WB2.Sheets("feuil1").Cells(fnObj + 13, fMonth.Colum n).NumberFormat = "0.00"
'-- 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
If Range("E" & fObj.Row) = 0 Or Range("E" & fObj. Row) = "" Or _
Range("F" & fObj.Row) = 0 Or Range("F" & fObj. Row) = "" Then _
Range("C" & fObj.Row) = 0: Range("D" & fObj.Ro w) = 0: Range("E" & fObj.Row) = 0: Range("F" & fObj.Row) = 0
WB2.Sheets("feuil1").Cells(fnObj.Row + 8, fMonth.Co lumn).Resize(5, 1).Value = Application.Transpose(WB1.Sheets("feuil1").Ran ge(Cells(fObj.Row, 2), Cells(fObj.Row, 6)).Value)
WB2.Sheets("feuil1").Cells(fnObj + 12, fMonth.Colum n).NumberFormat = "0.00"
WB2.Sheets("feuil1").Cells(fnObj + 13, fMonth.Colum n).NumberFormat = "0.00"
End If
'-------------------
0,60 après copie, ce qui semble normal.
Daniel
Alors y a-t-il une méthode pour avoir 60% en 60 sans le signe du pourcent age ?