Répéter macro sur ligne suivante

PierreGeo

XLDnaute Nouveau
Bonjour,

Je tiens à préciser que je suis novice en macro sur excel.

J'ai créé une macro qui marche bien (en gros je copie les données en ligne depuis l'onglet "Data" dans l'onglet "Sheet1" afin de les transposer en colonne)
Donc données ligne 1 de l'onglet "Data" copiées en colonne dans l'onglet "Sheet1" (13 cellules) avec également quelques autres manips

Je souhaiterais voir cette macro se répéter pour la ligne suivante de l'onglet "Data"
Et ce jusqu'à la fin du tableau

Merci beaucoup par avance pour votre aide


voici ma macro :

-----------------------------

Sub Everything3()
'
' Everything3 Macro
'
' Keyboard Shortcut: Ctrl+w
'
ActiveCell.Range("A1:B1").Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-5
ActiveCell.Offset(-13, 2).Range("A1:A13").Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(13, 0).Range("A1").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=15
ActiveCell.Offset(0, -2).Range("A1:B1").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=ActiveCell.Range("A1:B13"), Type:= _
xlFillCopy
ActiveCell.Range("A1:B13").Select
Sheets("Data").Select
ActiveCell.Offset(0, 2).Range("A1:M1").Select
Selection.Copy
Sheets("Sheet1").Select
ActiveCell.Offset(0, 4).Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(0, 1).Range("A1:M1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
ActiveCell.Offset(13, -4).Range("A1").Select
End Sub
 

Pièces jointes

  • demo_r_d3densbis.xls
    237 KB · Affichages: 50
Dernière édition:

klin89

XLDnaute Accro
Re : Répéter macro sur ligne suivante

Bonsoir PierreGeo, le forum :)

Non testé, attention au nom de la feuille de recopie des données, ici Feuil1.
VB:
Sub transpose()
Dim a, b(), i As Long, j As Long, k As Long, n As Long
    Application.ScreenUpdating = False
    a = Sheets("Data").Range("A7").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - 2), 1 To 4)
    For i = 2 To UBound(a, 1)
        For j = 3 To UBound(a, 2)
            n = n + 1
            For k = 1 To 2
                b(n, k) = a(i, k)
            Next
            b(n, 3) = a(1, j)
            b(n, 4) = a(i, j)
        Next
    Next
    With Sheets("Feuil1").Cells(1)
        .CurrentRegion.Clear
        .Resize(, 4).Value = [{"Geo","Geo","Année","Population"}]
        .Offset(1).Resize(n, 4).Value = b
        With .CurrentRegion
            With .Rows(1)
                .Interior.ColorIndex = 44
                .BorderAround Weight:=xlThin
            End With
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub
Edit : supprime les lignes parasites en fin de feuille "Data"

klin89
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re : Répéter macro sur ligne suivante

Bonsoir à tous


En attendant une solution avec Array (beaucoup plus rapide)
Voici une proposition testée sur le fichier joint
VB:
Sub mTransposeLC()
Dim dl&, i&
dl = Sheets("Data").Cells(Rows.Count, 1).End(3).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheet2.Range("A1:D1") = Array("GEO", "GEO", Chr(32), Chr(32))
For i = 8 To dl
Sheet2.Cells(Rows.Count, "A").End(3)(2).Resize(13).Value = Sheets("Data").Cells(i, 1).Value
Sheet2.Cells(Rows.Count, "B").End(3)(2).Resize(13).Value = Sheets("Data").Cells(i, 2).Value
Sheet2.Cells(Rows.Count, "C").End(3)(2).Resize(13).Value = Application.Transpose(Sheets("Data").Range("C7:O7").Value)
Sheet2.Cells(Rows.Count, "D").End(3)(2).Resize(13).Value = Application.Transpose(Sheets("Data").Cells(i, 3).Resize(, 13).Value)
Next
With Sheet2
.Columns("A:A").ColumnWidth = 8
.Columns("B:B").ColumnWidth = 52
.Columns("C:C").ColumnWidth = 5
.Columns("D:D").ColumnWidth = 7
.Range("A1").CurrentRegion.Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

EDITION:
Houps, désolé, pas vu passé klin89 (Bonsoir)
Bon bah voila plus besoin d'attendre la solution avec Array. ;)
 
Dernière édition:

Paf

XLDnaute Barbatruc
Re : Répéter macro sur ligne suivante

Bonjour à tous,

C'était fait donc je poste , même si ma version se rapproche de celle de klin89, mais sans mise en forme

Code:
Sub PierreGeo()
 Dim Source As Worksheet, Cible As Worksheet, DerLigS As Long, DerLigC As Long
 Dim TableauS, TableauC, i As Long, j As Long
 Set Source = Worksheets("Data")
 Set Cible = Worksheets("Feuil1") ' à adapter

 DerLigS = Source.Range("A" & Rows.Count).End(xlUp).Row

 Source.Range("A7:B7").Copy Cible.Range("A1")

 TableauS = Source.Range("A7:O" & DerLigS)
 ReDim TableauC(1 To ((UBound(TableauS) - 1) * 13 + 1), 1 To 4)

 For i = LBound(TableauS) + 1 To UBound(TableauS)
    For j = 3 To 15
        k = k + 1
        TableauC(k, 1) = TableauS(i, 1)
        TableauC(k, 2) = TableauS(i, 2)
        TableauC(k, 3) = TableauS(1, j)
        TableauC(k, 4) = TableauS(i, j)
        
    Next
 Next

Cible.Range("A2").Resize(UBound(TableauC, 1), UBound(TableauC, 2)) = TableauC

End Sub

Bonne soirée
 

Staple1600

XLDnaute Barbatruc
Re : Répéter macro sur ligne suivante

Re

Oui, c'est une nouvelle macro.
Tu la copies au même endroit que ta macro d'origine.
Il te reste juste à choisir entre celle de klin89 ou celle de Paf.

Au passage je confirme que les macros de klin89 et de PAf sont d'une fulgurante rapidité.
(On peut donc oublier ma macro sauf si on a besoin d'un peu de temps pour "touiller" son café ;))
 

Discussions similaires