Makro til at kopiere linier i Excel

Ja - og det kan du garanteret også selv, hvis du kikker lidt i www.eksperten.dk/spm/301628

PS: Hvis det kun skal gøres een gang, er det vist meget hurtigere at gøre manuelt end med en macro, der godt kan blive lidt voldsom...

Kan du ikke bare markere det hele, kopiere og indsætte speciel med transpose, fx under de eksisterende linier og så slette det oprindelige? Så slipper du for makroer og meget andet godtt.

Jeg har 338 rækker hvor jeg skal indsætte 11 rækker (insert copied cells) under hver række. Det kan gøres med en makro. Hvis jeg skulle gøre det manuelt vil det tage 2-3 timer.
Når dette er gjort skal jeg kopiere hver tolvte række og lave paste transpose - hvilket jeg også mener er hurtigere med en makro selv om det bare er en gang dette skal gøres.

OK!

Men så er det jo bare at klø på - kik på ovenstående link, i det svar du har afvist. Der står hvordan du kan indsætte rækker hvor du vil

Noget med for i = 1 to 338 ... :o)

Når du så har oprettet dine nye rækker som beskrevet i ovenstående, kan du kopiere dine ønskede celler:

    Cells(1, 5).Select
    Selection.Copy
    Cells(1, 1).Select
    ActiveSheet.Paste

Det er bare at udskifte tallene med variabler (fx. Cells(i, j).Select, og så lave et loop så i og j får passende værdier. Integ mystisk i det - men det tager lidt tid lige at lure, hvordan man skal varierer på i og j...

Husk at dim'me i og j som Integers

Prøv med denne makro, men gør det i en kopi først ;-) Jeg tror at den gør det du ønsker - hvis jeg altså har forstået dig rigtigt.

Sub CopyTranspose()
'
' Jan Kronsell Feb-03
Dim a As Byte
Dim b As Byte

a = 2
b = 13

For i = 1 To 338
    Rows(a & ":" & b).Select
    Selection.Insert Shift:=xlDown
    Range("G" & a - 1 & ":" & "R" & a - 1).Select
    Selection.Copy
    Range("G" & a & ":" & "G" & b).Select
    Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    ActiveCell.Offset(-1, 0).Activate
    ActiveCell.EntireRow.Select
    Selection.Delete Shift:=xlUp
a = a + 12
b = b + 12
Next i
End Sub

Hej jkrons
Jeg får den ikke helt til at virke.
Kan jeg evt. sende den til dig - så tror jeg det er nemmere - for jeg tror du har fat i den lange ende?

Send den bare til jkr@lyngby.nu, men jeg får nok først tid til at se på den i løbet af aftenen.

Jeg har modtaget arket, men jeg kan se at det er mere komplekst end det du skitserede i første omgang fordi, du har andre ting i regnearket, som der også skal tages højde for, fx navnene, som skal gentages i de nye rækker, og der er også flere rækker, der skal transposes, men den ene kun en gang osv. Jeg ser på det i løbet dagen.

Her er makroen. Jeg sender også arket direkte til dig lige om lidt.

Jeg håber at det nu fungerer som ønsket:

Sub CopyTranspose()
'
' Jan Kronsell 07 Feb-03
Dim A As Integer
Dim B As Integer

A = 3
B = 14

For i = 1 To 338

    Rows(A & ":" & B).Select
    Selection.Insert Shift:=xlDown
   
    Range("D1:O1").Select
    Selection.Copy
   
    Range("D" & A).Select
    Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
       
    Range("D" & A - 1 & ":" & "O" & A - 1).Select
   
    Selection.Copy
   
    Range("E" & A).Select
    Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    Range("A" & A - 1 & ":" & "C" & A - 1).Select
   
    Selection.AutoFill Destination:=Range("A" & A - 1 & ":" & "C" & B), Type:=xlFillDefault

    ActiveCell.EntireRow.Select
    Selection.Delete Shift:=xlUp
   
    A = A + 12
    B = B + 12

Next i

    Range("D1:O1").Select
    Selection.ClearContents
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Måned"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Beløb"
    Range("E2").Select
    Columns("D:D").EntireColumn.AutoFit
   
End Sub

Tak for hjælpen!

Velbekomme!