copier des cellules un nmobre de fois spécifié par d'autres cellules

bonjour a tous et a toutes

j'aimerai encore solliciter votre savoir en matiere de macro car le mien s'arrete à l'enregistreur (oui je sais c'est peu...).
je cherche donc à copier des cellules un nombre de fois spécifié par d'autre cellules.
un commentaire dans le fichier detaille l'operation.
si par cette belle journee vous avez encore un peu de temps, vous m'en ferez gagner beaucoup....

NB : si quelqu'un connait une lien vers divers exemples de macro lié au collage je suis preneur.

@+ emmanuel

Bonjour Man

Voici un code

Public Sub CopieXfois()
Dim vLigne As Double
Dim I As Double

vLigne = 1
For I = 1 To Range("J65536").End(xlUp).Row - 1
If Range("k1").Offset(I, 0) > 0 Then
Range(Range("G1").Offset(vLigne, 0), Range("G1").offset(vLigne + Range("k1").Offset(I, 0) - 1, 0)) = Range("J1").Offset(I, 0)
vLigne = vLigne + Range("k1").Offset(I, 0)
End If
Next

End Sub

Bonne journée

@+Jean-Marie

Jean Marie

un grand MERCI d'autant que ce n'est pas la premiere fois que tu m'aide.

ta macro fonctionne impec.
en plus je parviens un peu les dechiffrer, a comprendre les lignes de commande.
ca me fait plaisir, t'imagine pas !!! quand je clique sur le bouton et que la macro s'effectue c'est jouissif.

si t'es toujours dispo j'aurais dans quelques minutes la suite du probleme a te soumettre (ou au forum d'ailleurs).

merci encore.

Re Jean Marie et le forum,

Bon, j'ai un autre probleme de copiage a soumettre. il s'agit toujours de copier un nombre de fois spécifié par des cellules.
mais cette fois il y a une contrainte du fait que les cellules à copier sont les unes a la suite des autres et qu'il ne faudrait pas inserer de lignes supplementaires pour coller....
le fichier ci-joint sera plus explicite.

en attendant vos suggestions et notamment si cela est realisable car sinon il faudra que je modifie la structure de ma feuille.

d'avance merci.

Re...

Voici un code

Sub toto()
Dim c As Range
Dim firstAddress As String
Dim ChaineSelection As String
Dim I As Double

Application.ScreenUpdating = False

'efface les lignes
ChaineSelection = ""
With Range("C2", Range("C65536").End(xlUp).Address)
Set c = .Find("#", After:=Range("C2"))
If Not c Is Nothing Then
firstAddress = c.Address
Do
ChaineSelection = ChaineSelection & Range(c.Offset(0, -2), c.Offset(0, 2)).Address & ","

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
ChaineSelection = Mid(ChaineSelection, 1, Len(ChaineSelection) - 1)
Range(ChaineSelection).Select
Selection.Delete shift:=xlUp
End If
End With

'insère les lignes
Range("A1").Select
For I = Range("E65536").End(xlUp).Row To 2 Step -1
Range(Range("A1").Offset(I, 0), Range("E1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)).Insert shift:=xlDown
Range(Range("C1").Offset(I, 0), Range("C1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)) = "#"
Next

Application.ScreenUpdating = True
End Sub

Bonne soirée

Il doit y avoir plus simple, et aussi plus efficace, avec une gestion du nombre de lignes à supprimer ou à insérer en fonction du nombre de lignes existantes. Mais à ce niveau je tire ma révérence.

Bonne soirée

@+Jean-Marie

cher Jean Marie,

avant de tirer ta reverence permet moi de te remercier, de te congratuler, de te dire o combien c'est de la grande classe...

je ne sais pas s'il existe plus simple mais personnelement ca me va impec. quant à plus efficace j'en doute puisque c'est exactement ce que je voulais !!!

cela va me permettre de mener a bien un projet de planning de fabrication qui devrait me permettre d'etre plus efficace au boulot. comme ca je pourrais consacrer mon temps à autre chose comme apprendre le VBA...).

Bon encore dix mille merci. que ta joie soit aussi au moins aussi grande que la mienne, tu le mérite.

bonne soirée à toi O Jean Marie et tous les VBArtistes.

@+ Emmanuel

Re...

Un petit correctif

Sub toto()
Dim c As Range
Dim firstAddress As String
Dim ChaineSelection As String
Dim I As Double

Application.ScreenUpdating = False

'efface les lignes
ChaineSelection = ""
With Range("C2", Range("C65536").End(xlUp).Address)
Set c = .Find("#", After:=Range("C2"))
If Not c Is Nothing Then
firstAddress = c.Address
Do
ChaineSelection = ChaineSelection & Range(c.Offset(0, -2), c.Offset(0, 2)).Address & ","

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
ChaineSelection = Mid(ChaineSelection, 1, Len(ChaineSelection) - 1)
Range(ChaineSelection).Delete shift:=xlUp
End If
End With

'insère les lignes
For I = Range("E65536").End(xlUp).Row To 2 Step -1
Range(Range("A1").Offset(I, 0), Range("E1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)).Insert shift:=xlDown
Range(Range("C1").Offset(I, 0), Range("C1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)) = "#"
Next

Application.ScreenUpdating = True
End Sub

@+Jean-Marie

Bonsoir le forum et Jean Marie (si tu n'est pas plongé dans un mac...)

je reviens solliciter vos lumieres car je rencontre quelques soucis de fonctionnement avec la macro ci-après (celle developper par jean marie (voir post juste au dessus) a laquelle j'ai ajouté 2-3 codes.

j'ai joint un commentaire sur la premiere feuille du fichier ci joint pour expliquer l'utilité de la macro et les problemes rencontrés.
(a moins que la simple lecture du code ci-après vous parle !...).

si qq'un pouvait me venir en aide....


@+
emmanuel



Sub trier()
'
' trier Macro
' Macro enregistrée le 14/09/2003 par man


' deprotéger la feuille
ActiveSheet.Unprotect


'effacer le contenu des colonnes G et H
Range("G2:G250").Select
Selection.ClearContents
Range("H2:H250").Select
Selection.ClearContents

'trier les lignes
Range("A2:E250").Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


'ici commence la macro
Dim c As Range
Dim firstAddress As String
Dim ChaineSelection As String
Dim I As Double

Application.ScreenUpdating = False

'efface les lignes
ChaineSelection = ""
With Range("C2", Range("C65536").End(xlUp).Address)
Set c = .Find("#", After:=Range("C2"))
If Not c Is Nothing Then
firstAddress = c.Address
Do
ChaineSelection = ChaineSelection & Range(c.Offset(0, -2), c.Offset(0, 2)).Address & ","

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
ChaineSelection = Mid(ChaineSelection, 1, Len(ChaineSelection) - 1)
Range(ChaineSelection).Delete shift:=xlUp
End If
End With


'insère les lignes
For I = Range("E65536").End(xlUp).Row To 2 Step -1
Range(Range("A1").Offset(I, 0), Range("E1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)).Insert shift:=xlDown
Range(Range("C1").Offset(I, 0), Range("C1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)) = "#"
Next


Application.ScreenUpdating = True


Dim vLigne As Double

vLigne = 1
For I = 1 To Range("J65536").End(xlUp).Row - 1
If Range("k1").Offset(I, 0) > 0 Then
Range(Range("G1").Offset(vLigne, 0), Range("G1").Offset(vLigne + Range("k1").Offset(I, 0) - 1, 0)) = Range("J1").Offset(I, 0)
vLigne = vLigne + Range("k1").Offset(I, 0)
End If
Next

'fin de la macro

' recopier la formule de H2 à H250
Range("H2").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK(RC[-4]),"""",(RC[-4]-2)-RC[-1])"
Range("H2:H250").Select
Selection.FillDown

'se positionner en B2
Range("B2").Select

'protéger la feuille
ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

Bonjour Man

Toujours plongé dans mon micro préféré. J'ai regardé la modification que tu as faîte.

Voici mes remarques, pour la macro Trier.
Remplace la partie des lignes 'insère les lignes, par celle-ci, cela évite simplement d'insérer une ligne quand la commande est égale à 1. C'était la cause du problème.

'insère les lignes
For I = Range("E65536").End(xlUp).Row To 2 Step -1
If Range("E1").Offset(I - 1, 0) > 1 Then
Range(Range("A1").Offset(I, 0), Range("E1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)).Insert shift:=xlDown
Range(Range("C1").Offset(I, 0), Range("C1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)) = "#"
End If
Next

Il y a des petits aménagements à faire dans ta macro :
- Ces lignes
__Range("G2:G250").Select
__Selection.ClearContents
__Range("H2:H250").Select
__Selection.ClearContents

peuvent être remplacées par
Range("G2:H250").ClearContents

La ligne de réactivation de l'affichage Application.ScreenUpdating = True, doit être placée en fin de macro.

Je te conseille, de mettre les déclarations de variables en début de macro, juste en dessous des commentaires du créateur de la macro, c'est plus clair à la lecture du code.

@+Jean-Marie

Bonsoir Jean Marie et le forum,

merci d'avoir corrigé la macro. je l'ai bien testé et maintenant elle fonctionne.

Il y avait juste un dysfonctionnement lorsque je lancais 2 fois de suite la macro (ca boguait au niveau de la suppression des #), j'ai donc rajouté un code simple pour effacer les #. ca fonctionne impec. (cf plus bas)
ca me donne une macro par très catholique mais au moins ca fonctionne comme je le voulais et c'est l'essentiel.

Encore un grand merci pour ton aide. et surement à très bientot sur le forum.

@ +
emmanuel



Sub trier()

' deprotéger la feuille
ActiveSheet.Unprotect


'effacer le contenu des colonnes G et H
Range("G2:H250").Select
Selection.ClearContents

'trier les lignes
Range("A2:E250").Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


'effacer les #
Dim Plage As Range
Dim Cell As Range

Set Plage = Range("C2:C" & Range("C65535").End(xlUp).Row)

For Each Cell In Plage
If Cell.Value = "#" Then
Cell.Clear
End If
Next Cell


'ici commence la macro
Dim c As Range
Dim firstAddress As String
Dim ChaineSelection As String
Dim I As Double

Application.ScreenUpdating = False

'efface les lignes
ChaineSelection = ""
With Range("C2", Range("C65536").End(xlUp).Address)
Set c = .Find("#", After:=Range("C2"))
If Not c Is Nothing Then
firstAddress = c.Address
Do
ChaineSelection = ChaineSelection & Range(c.Offset(0, -2), c.Offset(0, 2)).Address & ","

Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
ChaineSelection = Mid(ChaineSelection, 1, Len(ChaineSelection) - 1)
Range(ChaineSelection).Delete shift:=xlUp
End If
End With


'insère les lignes
For I = Range("E65536").End(xlUp).Row To 2 Step -1
If Range("E1").Offset(I - 1, 0) > 1 Then
Range(Range("A1").Offset(I, 0), Range("E1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)).Insert shift:=xlDown
Range(Range("C1").Offset(I, 0), Range("C1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)) = "#"
End If
Next


Dim vLigne As Double

vLigne = 1
For I = 1 To Range("J65536").End(xlUp).Row - 1
If Range("k1").Offset(I, 0) > 0 Then
Range(Range("G1").Offset(vLigne, 0), Range("G1").Offset(vLigne + Range("k1").Offset(I, 0) - 1, 0)) = Range("J1").Offset(I, 0)
vLigne = vLigne + Range("k1").Offset(I, 0)
End If
Next

'fin de la macro

' recopier la formule de H2 à H250
Range("H2").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK(RC[-4]),"""",RC[-4]-(RC[-1]+2))"
Range("H2:H250").Select
Selection.FillDown


'enlever protection cellule
Range("A2:I65536").Select
Selection.Locked = False


'se positionner en B2
Range("B2").Select

'protéger la feuille
ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True

Application.ScreenUpdating = True


End Sub