Runtime error nogle gange når makro skal køres..

Prøv at sende en eksempel mappe, med den kode du bruger nu.
Skriv i en tekstboks på arket hvor og hvad der går galt, så ser jeg på det i aften.

kabbak snabela tiscali dot dk

Fejlen skyldes at samlefeltet overskrider, det antal tegn , der kan skrives direkte til alle celler på engang.
Koden er rettet, så den nu skriver til en celle af gangen, det gør den langsommere, end den var før, men det er den eneste udvej.

Sub Makro2()
    Dim Data As Variant, RW As Long, W As Long, I As Long, Y As Integer
    RW = Range("B65536").End(xlUp).Row
    Data = Range("A1:I" & RW)
    x = 0
    Y = ActiveCell.Column
    For I = 2 To UBound(Data)

        If Data(I, 2) = Data(I - 1, 2) Then    ' B kolonnen sammenlignes
            If x = 0 Then x = I - 1
            Data(x, Y) = Data(x, Y) & vbLf & Data(I, Y) ' Cellerne med ens nummer i kolonne B, sættes sammen i en celle
            Data(I, Y) = Empty ' tømmer cellen efter den er flyttet
        Else
            x = 0
        End If
    Next
   
    Range("A1:I" & RW).ClearContents ' tømmer cellerne for data
   
    W = 1
    For I = 1 To UBound(Data, 1)
        If Not IsEmpty(Data(I, Y)) Then
            For x = 1 To UBound(Data, 2)
                Cells(I, W) = Data(I, W) ' skriver data til cellerne
            Next
            W = W + 1
        End If
    Next

End Sub

Tænkte nok det var noget med antallet af tegn..

Desværre har jeg stadig problemer.. Kører med Excel 2003 SP3..

Når jeg kører makroen på hele datarækken får jeg denne fejl:

Run-time error '9':

Subscript out of range

Og det er så denne linje der er markeret med gult:

Cells(I, W) = Data(I, W) ' skriver data til cellerne

Når jeg er ude i excel-arket, efter at have kørt makroen, ser arket meget mærkeligt ud.. Næsten alt data er slettet..

Når jeg kører makroen på de rækker jeg har sendt til dig får jeg følgende fejl:

Der kommer ingen fejlmeddelse e.l. Men det eneste der er tilbage i arket er det som der var i A1, resten er slettet..

Jeg stiller mig i kolonne F før jeg kører makroen, jeg kan se det ser anderledes ud når jeg stiller mig i eks. kolonne B mv. Men regner med det som før?

Virker makroen hos dig?

Det er jo meningen at du stiller dig i den kolonne, der skal samles, så derfor skal du stå i ,(var det ikke kolonne F), jeg har slettet filen.

I eksemplet du sendte mig, er det rigtig at der kun er den i A1 tilbage, hvis din excel ikke automatisk ombryder teksten i cellerne, så højreklik på F kolonnen , vælg Formater celler > Justering, sæt flueben i ombryd tekst.

Angående
"Cells(I, W) = Data(I, W) ' skriver data til cellerne"

når den går i fejl( gul linje), så kør cursoren over I, så viser den værdien I har, den værdi vil jeg gerne vide.

Jeg har prøvet at sætte 'Wrap text' på (ombrydning af teksten) men det hjælper desværre ikke... Den laver desværre samme nummer.. Jeg har uploaded filen her: http://www.peet.dk/upload/uploads/1218711545.zip


Ang. fejlen når jeg kører makroen på det fulde excel-ark, så skriver den: I=59 W=10, håber det hjælper på løsningen af problemet..

der var en fejl i koden, men jeg ser at du har en delt mappe, jeg ved ikke om det har indflydelse på koden.

Sub Makro2()
    Dim Data As Variant, RW As Long, W As Long, I As Long, Y As Integer, W As Long, X As Long
    RW = Range("B65536").End(xlUp).Row
    Data = Range("A1:I" & RW)
    X = 0
    Y = ActiveCell.Column
    For I = 2 To UBound(Data)

        If Data(I, 2) = Data(I - 1, 2) Then    ' B kolonnen sammenlignes
            If X = 0 Then X = I - 1
            Data(X, Y) = Data(X, Y) & vbLf & Data(I, Y) ' Cellerne med ens nummer i kolonne B, sættes sammen i en celle
            Data(I, Y) = Empty ' tømmer cellen efter den er flyttet
        Else
            X = 0
        End If
    Next
 
    Range("A1:I" & RW).ClearContents ' tømmer cellerne for data
 
    W = 1
    For I = 1 To UBound(Data, 1)
        If Not IsEmpty(Data(I, Y)) Then
            For X = 1 To UBound(Data, 2)
                Cells(W, X) = Data(I, X) ' skriver data til cellerne
            Next
            W = W + 1
        End If
    Next

End Sub

Så lykkes det sgu, mange gange tak for hjælpen :) Send et svar så du kan få points!

et svar ;-))