fonction evitant de retaper inutilement 1 macro

[jean]

bonjour a tous

je cheche une fonction qui m'eviterait de retaper le code toutes les 500 lignes
dans la formule ci dessous range 'A500' et 'achat' sont les elements variables.
ex: (A500,achat) (A1000,vente) (A1500,production) (A2000,maintenance) etc.....
existe t'il une fonction m'evitant de retaper le code..

merci



Sub SelectionCopier()
Application.ScreenUpdating = False
Workbooks.Open Filename:='c:\\basededonnées2.xls'
Windows('basededonnées2.xls').Activate
For X = 1 To 65536
If Worksheets('1').Cells(X, 3) = 'achat' Then
Z = Workbooks('Logiciel suivi des coûts.xls').Worksheets('semaine 1').Range('A500').End(xlUp).Row + 1
For Y = 1 To 16
Workbooks('Logiciel suivi des coûts.xls').Worksheets('semaine 1').Cells(Z, Y) = Worksheets('1').Cells(X, Y)
Next
End If
Next
ActiveWorkbook.Close False

Application.ScreenUpdating = True
End Sub

 

[PascalXLD]

Bonjour

essaies ceci

Sub SelectionCopier()
Dim MaLigne as Integer
Application.ScreenUpdating = False
Workbooks.Open Filename:='c:basededonnées2.xls'
Windows('basededonnées2.xls').Activate
For X = 1 To Worksheets('1').Cells(65536, 3).end(xlup).row
select case Worksheets('1').Cells(X, 3)
case 'achat'
MaLigne=500
case 'vente'
MaLigne=1000
case 'production
MaLigne=1500
case else
MaLigne=0
end select
If MaLigne<>0 Then
Z = Workbooks(\\'Logiciel suivi des coûts.xls\\').Worksheets(\\'semaine
1\\').Range(\\'A\\' & MaLigne).End(xlUp).Row + 1
For Y = 1 To 16
Workbooks(\\'Logiciel suivi des coûts.xls\\').Worksheets(\\'semaine 1\\').Cells(Z, Y) =
Worksheets(\\'1\\').Cells(X, Y)
Next
End If
Next
ActiveWorkbook.Close False

Application.ScreenUpdating = True
End Sub

 

[Creepy]

Bonjour à toutes & tous,

Alors si j'ai bien compris tu veux que ta macro fonctionne pour A500, puis A1000, A1500, etc...

Voila ce que j'ai fait sachant qua la macro s'arrete à 1500 !

Sub SelectionCopier()

Dim I As Integer

Application.ScreenUpdating = False
Workbooks.Open Filename:='c:basededonnées2.xls'
Windows('basededonnées2.xls').Activate

I = 500

Boucle:

For X = 1 To 65536
If Worksheets('1').Cells(X, 3) = 'achat' Then
Z = Workbooks('Logiciel suivi des coûts.xls').Worksheets('semaine1').Range('A' & I).End(xlUp).Row + 1
For Y = 1 To 16
Workbooks('Logiciel suivi des coûts.xls').Worksheets('semaine 1').Cells(Z, Y) = Worksheets('1').Cells(X, Y)
Next
End If
Next

I = I + 500
If I < 2000 Then
GoTo bloucle
End If

ActiveWorkbook.Close False

Application.ScreenUpdating = True
End Sub


++

Creepy

Ps : Si ce n'est pas ce que tu voulais, met un petit exemple en PJ pour que ce qoit plus claire !

 

[jean]

merci pour vos reponses mais je pense ne pas avoir tres bien explique ce que je voulais

voila donc un fichier exemple de ce qu'il me faut il est peut etre agencé d'une facon etrange mais en tout cas correspond a ma demande.


merci d'avance


[file name=jeanbis.zip size=5882]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/jeanbis.zip[/file]

 

[jean]

s'il vous plait

 

[PascalXLD]

Re

Tu peux me dire ce qui ne marche pas avec ce que je t'ai donné car il me semble que ce que j'ai fait correspond

 

[jean]

salut,

en fait avec ce que tu m'as donné les lignes 'achat,vente,maintenance...' ce collent au meme endroit. je voudrais que la ligne achat ce colle ligne 500
que la ligne vente ligne 1000
et la ligne maintenance ce colle ligne 1500

merci pascal

 

[PascalXLD]

Re

Non les lignes ne se collaient pas au même endroit

Je te joins ton fichier modifié

T'inquiètes des exemples faux sur ta feuille car l'ordre n'est pas le même qu'au départ [file name=jeanbis_20050627133857.zip size=8714]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/jeanbis_20050627133857.zip[/file]

 

[jean]

ok je me suis trompé sur un point

merci bcp ca marche.