J=92aimerais recopier les valeurs Bx:Fx du classeur1 dans la colonne du moi=
s pass=E9 du classeur2.
Pour le moment, j=92ai une erreur pour ouvrir le classeur2 (LHCF.xls)
Le r=E9sultat 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 =3D Workbooks("TQ (1).xls")
Set WB2 =3D Workbooks.Open("LHCF.xls")
'-- Mois pass=E9
mF =3D Format(DateAdd("m", -1, Date), "mmm")
With WB1.Sheets("feuil1")
'-- Tableaux contenant les noms (Col H) et leurs =E9quivalences en =
objet (Col I)
tb =3D .Range("H2:I" & [H65000].End(xlUp).Row).Value
'-- Plage des objets dans classeur1
Set obPlg =3D .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 =3D .Range(.Cells(9, 1), .Cells(.Cells.Rows.Count, 1).En=
d(xlUp) _
.Offset(1, 0)) ' Pour faire en=
trer la derniere cellule fusionn=E9e
'-- Plage des mois dans classeur2
Set mPlg =3D .Range(.Cells(7, 1), .Cells(7, 256).End(xlToLeft))
End With
'-- Recherche du mois pass=E9
Set fMonth =3D mPlg.Find(mF)
For i =3D LBound(tb) To UBound(tb)
If Len(tb(i, 1)) > 0 Then
Set fnObj =3D obnPlg.Find(tb(i, 1), LookIn:=3DxlValues, LookAt:=
=3DxlPart)
If Not fnObj Is Nothing Then
Set fObj =3D obPlg.Find(tb(i, 2), LookIn:=3DxlValues, LookA=
t:=3DxlPart)
If Not fObj Is Nothing Then
'-- Si l'objet trouv=E9 se termine par un D
'-- On commence l'=E9criture juste =E0 la ligne de fnOb=
j dans classeur2
Chn =3D WB1.Sheets("feuil1").Range("A" & fObj.Row)
If Mid(Chn, Len(Chn), 1) =3D "D" Then
WB2.Sheets("feuil1").Cells(fnObj.Row, fMonth.Column=
).Resize(4, 1).Value =3D Application.Transpose(WB1.Sheets("feuil1").Range(C=
ells(fObj.Row, 2), Cells(fObj.Row, 7)).Value)
'-- Si l'objet trouv=E9 se termine par un A
'-- On commence l'=E9criture =E0 la ligne de fnObj + 8 =
lignes en bas dans classeur2
ElseIf Mid(Chn, Len(Chn), 1) =3D "A" Then
WB2.Sheets("feuil1").Cells(fnObj.Row + 8, fMonth.Co=
lumn).Resize(4, 1).Value =3D 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 =3D Nothing: Set WB2 =3D Nothing: Set mPlg =3D Nothing
Set obnPlg =3D Nothing: Set fnObj =3D Nothing: Set obPlg =3D Nothing: S=
et fObj =3D Nothing
End Sub
'-------------------------------------------------------------
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
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
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
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):
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):
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):
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.
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.
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
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
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
'-- 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
'-- 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
'-- 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