tekststreng til 1 eller flere arrays/arraylist afgh. af længde

Hej

Kan du måske bruge noget som dette ?

MyString = "x y z d df f dsf dsf sf .... "

' split into 1 helt array
MyArray = split(mystring, " ")

' overfør de første 5 til array1
For I = 1 to 5
MyArr1(i) = myArray(i)
next

overfør efterfølgende til array2
for i = 6 to XX
myarr2(i -6) = myarr(i)
next

//akj

Public Sub OpdelStreng()
    Dim StrVar() As Variant, I As Integer, Str As String, X As Integer
    Str = "Connecting pipe 8 pcs 168,3x14,2  L=12500 mm, Total L=100 m,<-første array> matr. P235GH TCII, certificate 3.1B<-resten i andet array>"
    I = 0
    Do
        ReDim Preserve StrVar(I)
        For X = 60 To 1 Step -1
            If Mid(Str, X, 1) = " " Then
                StrVar(I) = Left(Str, X)
                Str = Right(Str, Len(Str) - X)
                I = I + 1
                Exit For
            ElseIf Len(Str) < 60 Then
                StrVar(I) = Str
                Str = ""
                Exit For
            End If
        Next
    Loop Until Len(Str) = 0
End Sub

Opdelingen er i StrVar

jeg flyttede lige lidt om på rækkefølgen.

Public Sub OpdelStreng()
    Dim StrVar() As Variant, I As Integer, Str As String, X As Integer
    Str = "Connecting pipe 8 pcs 168,3x14,2 L=12500 mm, Total L=100 m, matr. P235GH TCII, certificate 3.1B"
    I = 0
    Do
        ReDim Preserve StrVar(I)
        If Len(Str) < 60 Then
            StrVar(I) = Str
            Str = ""
            Exit Do
        Else
            For X = 60 To 1 Step -1
                If Mid(Str, X, 1) = " " Then
                    StrVar(I) = Left(Str, X)
                    Str = Right(Str, Len(Str) - X)
                    I = I + 1
                    Exit For
                End If
            Next
        End If
    Loop Until Len(Str) = 0
End Sub

Ser du til at virke - takker

et svar ;-))

Her er også en mulighed, selv om kabbak selvfølgelig skal have dine point, for han kom jo først med en rutine der virker.

Public Function Splitline(strInput As String, Linelen As Integer) As Variant
    Dim LineArr() As String    'Array til de opdelte "linier"
    Dim l As Integer    'Antallet af afsatte "linier"
    Dim i As Integer    'Array index
    Dim lp As Integer  'Lower position
    Dim up As Integer  'Upper position
    Dim sp As Integer  'Splitting position
    Dim fl As Integer  'Antallet af "fejl" = antallet af for lange elementer
    l = 1000            'Start med at afsætte 1000 "linier"
    ReDim LineArr(l)
    If Len(strInput) > Linelen Then
        up = Linelen
        i = 0: lp = 1
        Do Until lp > Len(strInput)
            sp = InStrRev(strInput, " ", up)
            If sp > lp Then
                'Normal linie
                LineArr(i) = Mid(strInput, lp, sp - lp)
            Else
                'Det var ikke muligt at opsplitte det valgte afsit af strengen...
                fl = fl + 1    'Sæt antallet af for lange elementer
                If up < Len(strInput) Then
                    'Det er ikke i slutningen af strengen.
                    'Vi er nødt til at gøre arrayelementet længere end "aftalt".
                    'Søg derfor op til næste blanke...
                    sp = InStr(up, strInput, " ")
                    If sp = 0 Then
                        'Der var ikke flere blanke. Sæt arrayelementet til resten af strengen...
                        sp = Len(strInput) + 1
                    End If
                Else
                    sp = up + 1
                End If
                LineArr(i) = Mid(strInput, lp, sp - lp)
            End If
            lp = sp + 1              'Sæt den nye nedre grænse
            up = lp + Linelen - 1    'Sæt den nye øvre grænse
            If up > Len(strInput) Then
                up = Len(strInput)
            End If
            i = i + 1          'Sæt det nye arrayelement
            If i > l Then
                'Afsæt flere "linier"
                l = l + 100
                ReDim Preserve LineArr(l)
            End If
        Loop
        i = i - 1              'Der var ikke brug for elementet, sæt det 1 tilbage
    Else
        LineArr(0) = strInput
        If strInput > Linelen Then
            fl = 1
        End If
    End If
    ReDim Preserve LineArr(i)
    Splitline = LineArr()
    If fl > 0 Then
        MsgBox fl & " linier kunne ikke deles i den ønskede længde på max. " & Linelen & " tegn."
    End If
End Function

Oops, der var en lille fejl i koden:

ublic Function Splitline(strInput As String, Linelen As Integer) As Variant
    Dim LineArr() As String    'Array til de opdelte "linier"
    Dim l As Integer    'Antallet af afsatte "linier"
    Dim i As Integer    'Array index
    Dim lp As Integer  'Lower position
    Dim up As Integer  'Upper position
    Dim sp As Integer  'Splitting position
    Dim fl As Integer  'Antallet af "fejl" = antallet af for lange elementer
    l = 1000            'Start med at afsætte 1000 "linier"
    ReDim LineArr(l)
    If Len(strInput) > Linelen Then
        up = Linelen
        i = 0: lp = 1
        Do Until lp > Len(strInput)
            sp = InStrRev(strInput, " ", up)
            If sp <= lp Then
                'Det var ikke muligt at opsplitte det valgte afsit af strengen...
                fl = fl + 1    'Sæt antallet af for lange elementer
                If up < Len(strInput) Then
                    'Det er ikke i slutningen af strengen.
                    'Vi er nødt til at gøre arrayelementet længere end "aftalt".
                    'Søg derfor op til næste blanke...
                    sp = InStr(up, strInput, " ")
                    If sp = 0 Then
                        'Der var ikke flere blanke. Sæt arrayelementet til resten af strengen...
                        sp = Len(strInput) + 1
                    End If
                Else
                    sp = up + 1
                End If
            End If
            LineArr(i) = Mid(strInput, lp, sp - lp)
            lp = sp + 1              'Sæt den nye nedre grænse
            up = lp + Linelen - 1    'Sæt den nye øvre grænse
            If up >= Len(strInput) Then
                LineArr(i) = Right(strInput, Len(strInput) - lp + 1)
                lp = Len(strInput) + 1
            End If
            i = i + 1          'Sæt det nye arrayelement
            If i > l Then
                'Afsæt flere "linier"
                l = l + 100
                ReDim Preserve LineArr(l)
            End If
        Loop
        i = i - 1              'Der var ikke brug for elementet, sæt det 1 tilbage
    Else
        LineArr(0) = strInput
        If strInput > Linelen Then
            fl = 1
        End If
    End If
    ReDim Preserve LineArr(i)
    Splitline = LineArr()
    If fl > 0 Then
        MsgBox fl & " linier kunne ikke deles i den ønskede længde på max. " & Linelen & " tegn."
    End If
End Function

Jeg ved ikke om den er helt fejlfri nu, men jeg har prøvet at teste den med nedenstående:

Sub testsplit(streng As String, linielen As Integer)
    Dim strLine As String
    Dim arr As Variant
    Dim i As Integer
    arr = Splitline(streng, linielen)
    Debug.Print "Elementer="; UBound(arr) + 1
    For i = 0 To UBound(arr)
        Debug.Print Len(arr(i)), arr(i)
    Next
End Sub

testsplit "Dette er en lille test af min rutine, som skal vise, at en streng kan opdeles i dele, hvis længde bestemmes af en <længde> parameter.",30

Det returnerer følgende, som jeg mener er korrekt:

Elementer= 5
29          Dette er en lille test af min
28          rutine, som skal vise, at en
26          streng kan opdeles i dele,
27          hvis længde bestemmes af en
19          <længde> parameter.

skal vi ikke se at få lukket ???