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.
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 3
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
DanielCo
Le #24550011
Bonjour,
Le lien n'est pas disponible.
Daniel
Apitos
Le #24550151
Bonjour Daniel,

Le voila à nouveau :

http://cjoint.com/?BFkx5djmCqV
DanielCo
Le #24550421
Quand on ouvre un classeur, il est souhaitable de préciser le chemin à
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


Bonjour Daniel,

Le voila à nouveau :

http://cjoint.com/?BFkx5djmCqV
Apitos
Le #24550471
Re,

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)
DanielCo
Le #24550631
Quel est le libellé de l'erreur ?
Daniel
Apitos
Le #24550801
Quel est le libellé de l'erreur ?



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.
DanielCo
Le #24550871
Par exemple, au lieu d'avoir :

- 44,70 j'ai 0.44
- 87,33 j'ai 0.87



L'écriture se fait à quel niveau dans la macro ? quel est le format de
la cellule ?
Daniel
Apitos
Le #24551051
J'ai essayé de formater les valeurs résultantes, mais sans rien d'obten u :

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

'-------------------
DanielCo
Le #24551901
Je ne vois pas d'anomalie. Les cellules en % eg. 60% se retrouvent en
0,60 après copie, ce qui semble normal.
Daniel
Apitos
Le #24552041
Bonsoir Daniel,

Je ne vois pas d'anomalie. Les cellules en % eg. 60% se retrouvent en
0,60 après copie, ce qui semble normal.



Alors y a-t-il une méthode pour avoir 60% en 60 sans le signe du pourcent age ?
Publicité
Poster une réponse
Anonyme