Vend rækker til kolonner i hver sin arkfane

For forståelsens skyld:

Data er i et ark, og der skal altså oprettes nye ark for hver række her?

Jeg går ud fra, at du benytter Excel 2007 eller 2010, hvor der i teorien ikke er en øvre grænse for, hvor mange ark, der kan oprettes (omend mængden af RAM kan sætte grænsen!).

Hvor mange rækker og kolonner er der cirka i datamaterialet?

Hej natkat

Jeg benytter Office 2003, men mener ikke at det skulle give probler i det aktuelle tilfælde, har før haft flere end 600 arkfaner i samme regneark uden nævneværdige problemer.

Datamaterialet jeg skal have behandlet består af kolonne A - DP
og 548 rækker

Jeg er startet ( af tidsnød ) på en mulig løsning

Dette her gør arbejdet for den første del.

    Sheets("Sheet1").Select
        Range("1:1,2:2").Select
            Range("A1").Activate
                Selection.Copy
    Sheets("Sheet1").Select
        Sheets.Add
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, TransPose:=True
    Sheets(ActiveSheet.Name).Name = Range("B1")

Jeg har behov for en loop rutine som løber hele regnéarket igennem. 

Linie 2 i koden skal i 2 loop se således ud : 

Range("1:1,3:3").Select

i 3 loop således

Range("1:1,4:4").Select

Er lige begyndt på et forslag i skrivende stund..

Rart med venner herinde :-)

Dim basisArk As Worksheet
Dim antalRæk As Long
Public Sub transponerOgFordel()
Dim id
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
    Set basisArk = ActiveWorkbook.Sheets(basisArkNavn)
   
    Application.ScreenUpdating = False
   
    For ræk = 2 To antalRæk
        basisArk.Select
        id = Range("A" & ræk)
        Union(Range("1:1"), Range(ræk & ":" & ræk)).Select
       
        Selection.Copy
        ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = id
        ActiveSheet.Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

        Application.CutCopyMode = False
    Next ræk
   
    Application.ScreenUpdating = True
End Sub

Fejl :
Subscript out of range

Undskyld - den første linje manglede


Const basisArkNavn = "Ark1"        '<--- justeres

Dim basisArk As Worksheet
Dim antalRæk As Long
Public Sub transponerOgFordel()
Dim id
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
    Set basisArk = ActiveWorkbook.Sheets(basisArkNavn)
   
    Application.ScreenUpdating = False
   
    For ræk = 2 To antalRæk
        basisArk.Select
        id = Range("A" & ræk)
        Union(Range("1:1"), Range(ræk & ":" & ræk)).Select
       
        Selection.Copy
        ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = id
        ActiveSheet.Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

        Application.CutCopyMode = False
    Next ræk
   
    Application.ScreenUpdating = True
End Sub

Så er den ged barberet :-)

Tak for hjælpen

Selv tak og et svar