copier des plages

[lodge]

bonjour,

je souhaite copier des plages de cellules

merci pour votre aide

 

[Softmama]

Re : copier des plages

Bonjour,

ceci à tester :

Sub test1()
Dim c As Range, a As Long
Set c = [A2]
a = Feuil1.UsedRange.Rows.Count + 1
Do While c.Row < a
  c.Resize(, 3).AutoFill c.Resize(IIf(c.End(xlDown).Row < 65000, c.End(xlDown).Row - c.Row, 9), 3)
  Set c = c.End(xlDown)
Loop
End Sub

 

[job75]

Re : copier des plages

Bonsoir lodge, salut Softmama 🙂

Voir le fichier joint.

La macro dans Module1 (Alt+F11) :

Sub Copier()
Dim F1 As Worksheet, F2 As Worksheet, plage1 As Range, plage2 As Range
Set F1 = Feuil1 'CodeName
Set F2 = Feuil2
Set plage1 = Intersect(F1.[A:D], F1.UsedRange)
Set plage2 = F2.Range(plage1.Address)
F2.[A:D].ClearContents 'RAZ
plage2 = plage1.Value 'copie les valeurs
plage2.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
plage2 = plage2.Value 'supprime les formules
F2.Activate 'facultatif
End Sub

A+

 

[job75]

Re : copier des plages

Re,

S'il s'agit juste de remplir le tableau de la 1ère feuille, c'est évidemment plus simple :

Sub Remplir()
Dim F As Worksheet, plage As Range
Set F = Feuil1 'CodeName
Application.ScreenUpdating = False
On Error Resume Next
Set plage = Intersect(F.[A:C], F.UsedRange)
plage.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
plage = plage.Value 'supprime les formules
End Sub

Fichier joint.

A+

 

[job75]

Re : copier des plages

Bonjour le fil, le forum,

S'il y a des cellules non vides en ligne 1 définir plage par :

Set plage = Intersect(F.[A2:C65536], F.UsedRange)

Fichier (2).

Edit : concernant la durée d'exécution.

J'ai recopié le tableau jusqu'à la ligne 64401 => 29 secondes sur XP/Excel 2003.

La méthode AutoFill de Softmama est beaucoup plus rapide => 1 seconde.

L'ennui c'est qu'elle incrémente : a1a1 a1a2 a1a3...

A+

 

[job75]

Re : copier des plages

Re,

En utilisant le tableau tablo c'est beaucoup plus rapide : 1,09 s sur 64401 lignes.

Sub Remplir()
Dim F As Worksheet, tablo, i As Long
Set F = Feuil1 'CodeName
Application.ScreenUpdating = False
tablo = Intersect(F.[A2:C65536], F.UsedRange)
For i = 2 To UBound(tablo)
  If tablo(i, 1) = "" Then
    tablo(i, 1) = tablo(i - 1, 1)
    tablo(i, 2) = tablo(i - 1, 2)
    tablo(i, 3) = tablo(i - 1, 3)
  End If
Next
[A2:C2].Resize(UBound(tablo)) = tablo
End Sub

Fichier (3).

A+

 

[lodge]

Re : copier des plages

merci, cela fonctionne parfaitement !!