Kolonner til rækker - programmering

Forøvrigt har jeg engang set at man kan tilføje en funktion, som løbende viser hvor mange %, som makroen har udført. Hvis nogle ved hvordan den laves vil jeg også være interesseret i at have denne indbygget.

prøv

Sub FlytDataFlow()
    Dim Koll As Integer
    Dim Rækk As Integer
    Dim NyeData As Long
    Dim Data As Variant

    NyeData = 2
    Rækk = 5

    While Len(Ark1.Cells(Rækk, 1).Value) > 0
        For Koll = 8 To 63
            If Len(Ark1.Cells(Rækk, Koll).Value) > 0 Then
                Data = Array("VRW", 3140, Ark1.Cells(Rækk, 1).Value, Ark1.Cells(Rækk, 2).Value, Ark1.Cells(Rækk, 3).Value, Ark1.Cells(Rækk, 3).Value, "X", Ark1.Cells(1, Koll).Value, Ark1.Cells(Rækk, Koll).Value, "PC")
                Worksheets("Ark5").Range(Cells(NyeData, LBound(Data) + 1), Cells(NyeData, UBound(Data) + 1)) = Data
               
                '  Worksheets("Ark5").Cells(NyeData, 1).Resize(LBound(Data), UBound(Data)) = Data
                '                Ark5.Cells(NyeData, 1) = "VRW"
                '                Ark5.Cells(NyeData, 2) = "3140"
                '                Ark5.Cells(NyeData, 3) = Ark1.Cells(Rækk, 1).Value
                '                Ark5.Cells(NyeData, 4) = Ark1.Cells(Rækk, 2).Value
                '                Ark5.Cells(NyeData, 5) = Ark1.Cells(Rækk, 3).Value
                '
                '                Ark5.Cells(NyeData, 6) = Ark1.Cells(Rækk, 3).Value
                '                Ark5.Cells(NyeData, 7) = "X"
                '                Ark5.Cells(NyeData, 8) = Ark1.Cells(1, Koll).Value
                '                Ark5.Cells(NyeData, 9) = Ark1.Cells(Rækk, Koll).Value
                '                Ark5.Cells(NyeData, 10) = "PC"
                NyeData = NyeData + 1
            End If

        Next Koll
        Rækk = Rækk + 1
    Wend
End Sub

Nu er der % på, ses på statusbaren

Jeg fyldte et ark på 55777 rækker på en 15 sek.

Sub FlytDataFlow()
    Dim Koll As Integer
    Dim Rækk As Integer
    Dim NyeData As Long
    Dim Data As Variant, PRC As Integer
   

    NyeData = 2
    Rækk = 5
PRC = Ark1.Range(Ark1.Range("BA5"), Ark1.Range("BA5").End(xlDown)).Rows.Count
    While Len(Ark1.Cells(Rækk, 1).Value) > 0
        For Koll = 8 To 63
            If Len(Ark1.Cells(Rækk, Koll).Value) > 0 Then
                Data = Array("VRW", 3140, Ark1.Cells(Rækk, 1).Value, Ark1.Cells(Rækk, 2).Value, Ark1.Cells(Rækk, 3).Value, Ark1.Cells(Rækk, 3).Value, "X", Ark1.Cells(1, Koll).Value, Ark1.Cells(Rækk, Koll).Value, "PC")
                Worksheets("Ark5").Range(Cells(NyeData, LBound(Data) + 1), Cells(NyeData, UBound(Data) + 1)) = Data
                NyeData = NyeData + 1
            End If

        Next Koll
        Rækk = Rækk + 1
        Application.StatusBar = "mangler " & Int(PRC / (Rækk - 4)) & " %"
    Wend
End Sub

Alternativt :

Sub Transponer()
Set sh = Sheets("Ark5")
Set sh1 = Sheets("Ark1")
rk = sh1.Cells(10000, 8).End(xlUp).Row
x = sh1.Range(sh1.Cells(5, 8), sh1.Cells(rk, 63))
sh.Range(sh.Cells(2, 2), sh.Cells(UBound(x, 2) + 1, UBound(x, 1) + 1)) = WorksheetFunction.Transpose(x)
End Sub

Hej Kabbak
Det var helt perfekt, kabbak. Trods min beskedne viden om VBA kan jeg dog ikke forstå, hvorfor min løsning tager 8 timer og din tager 22 sek, men bare det virker, så er det jo fint. Statusbaren er dog ikke helt perfekt, da den starter på 1000% (eller deromkring) og på 1/4 sek går den ned på 19% og derefter kører den så langsomt ned. Men det er jo også mindre relevant når nu hele tiden er reduceret til 22 sekunder.
Læg et svar, så får du dine velfortjente point.

;-)

Så må der jo være en fejl i udregningen af %, det kan du måske selv ordne.

Du kan jo også bare fjerne linjen
Application.StatusBar = "mangler " & Int(PRC / (Rækk - 4)) & " %"

det gør måske også noget på hastigheden.
Forskellen på dit og mit, er at jeg arbejder med en variabel "Data As Variant", det er hurtigere at læse ind i den ende at sige at en celle er = en anden og det går endnu hurtigere at skrive en variabel til celler, vi kan måske speede den lidt mere, ved at så skærmopdateringen og beregning fra.

Her har jeg sat det ind og fjerner det med %.

Sub FlytDataFlow()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Dim Koll As Integer
    Dim Rækk As Integer
    Dim NyeData As Long
    Dim Data As Variant, PRC As Integer

    NyeData = 2
    Rækk = 5
    While Len(Ark1.Cells(Rækk, 1).Value) > 0
        For Koll = 8 To 63
            If Len(Ark1.Cells(Rækk, Koll).Value) > 0 Then
                Data = Array("VRW", 3140, Ark1.Cells(Rækk, 1).Value, Ark1.Cells(Rækk, 2).Value, Ark1.Cells(Rækk, 3).Value, Ark1.Cells(Rækk, 3).Value, "X", Ark1.Cells(1, Koll).Value, Ark1.Cells(Rækk, Koll).Value, "PC")
                Worksheets("Ark5").Range(Cells(NyeData, LBound(Data) + 1), Cells(NyeData, UBound(Data) + 1)) = Data
                NyeData = NyeData + 1
            End If

        Next Koll
        Rækk = Rækk + 1

    Wend
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Tjekker du lige om den sidste giver yderligere forøgelse af hastigheden. ?
Det interesserer mig, om det hjalp yderligere, det med skærmopdatering og beregning.

Det ser super godt ud det med at man kan få en % sats der mangler i afviklingen af makroen.
Jeg har prøvet at afvikle følgende:

PRC = Ark1.Range(Ark1.Range("BA5"), Ark1.Range("BA5").End(xlDown)).Rows.Count

og til sidst

Application.StatusBar = "mangler " & Int(PRC / (Rækk - 4)) & " %

Men det tæller ikke hos mig..
Den viser hele tiden 0%
Kan du hjælpe mig Kabbak

nu er der % på igen, den virker ved mig

Sub FlytDataFlow()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Dim Koll As Integer
    Dim Rækk As Integer
    Dim NyeData As Long
    Dim Data As Variant, PRC As Integer, Pc As Double
    PRC = Ark1.Range(Ark1.Range("BA5"), Ark1.Range("BA5").End(xlDown)).Rows.Count
    NyeData = 2
    Rækk = 5
    While Len(Ark1.Cells(Rækk, 1).Value) > 0
        For Koll = 8 To 63
            If Len(Ark1.Cells(Rækk, Koll).Value) > 0 Then
                Data = Array("VRW", 3140, Ark1.Cells(Rækk, 1).Value, Ark1.Cells(Rækk, 2).Value, Ark1.Cells(Rækk, 3).Value, Ark1.Cells(Rækk, 3).Value, "X", Ark1.Cells(1, Koll).Value, Ark1.Cells(Rækk, Koll).Value, "PC")
                Worksheets("Ark5").Range(Cells(NyeData, LBound(Data) + 1), Cells(NyeData, UBound(Data) + 1)) = Data
                NyeData = NyeData + 1
            End If
        Next Koll
        Application.StatusBar = "mangler " & Format(100 - ((Rækk - 4) / PRC) * 100, "###.#0") & " %"

        Rækk = Rækk + 1
    Wend
    Application.StatusBar = ""
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Jeg har oprettet et spm på netop dette:
http://www.eksperten.dk/spm/921455

Hej Kabbak

% virker også fint hos mig - har dog lavet den om, så den tæller op til 100%.

Tidsforbruget blev væsentlig bedre. Før tog det 88 sekunder, men efter at have slået beregning og skærmopdatering fra tog det kun 28 sekunder.