Szia, kezdem azzal, hogy borzasztóan nehéz ennyire következetlen adatbevitellel kezdeni valamit.

 

Én mindenesetre megpróbálkoztam az általad írt minta alapján úgy szétszedni az adataidat, hogy lehessen kezdeni valamit. 

 

Nem vacakoltam azzal, hogy az eredményt összefűzzem, és + jeleket tegyek az egyes részek közé. Csak annyit tettem, hogy a 10. (J) oszloptól kezdődően külön oszlopokban tegyem az egyes adatrészeket.

Feltételeztem továbbá, hogy van fejléc, ezért a 2. sortól indítottam a keresést. És mivel kevés példa volt, csak 3 mintával foglalkoztam:

 

GK-8201 Bgkfdez - BZ-88888 Jobtagj -UU-87896 Hjulohdt

8201 Bgkfdez - BZ-88888 Jobtagj -UU-87896 Hjulohdt

GK8201 Bgkfdez - BZ-88888 Jobtagj -UU87896 Hjulohdt

 

 

Ezeknél a program jól szedi szét a sorokat. Nézd meg, hogy a többi is működik-e.

 

Ez a program:

 

 

Option Explicit

Const kezdooszlop As Long = 10 '  oszlop

Sub konvertal()

Dim ws As Worksheet, utolsosor As Long, i As Long, sor As Long, celoszlop As Long, forrasstring As String, adatstring As String

Set ws = ActiveSheet

utolsosor = ws.Range("A" & Rows.Count).End(xlUp).Row

For sor = 2 To utolsosor

    celoszlop = kezdooszlop

    forrasstring = ws.Cells(sor, 1)

    Do

        If Not karkeres(forrasstring) Then Exit Do

        If Asc(UCase(Left(forrasstring, 1))) > 64 And Asc(UCase(Left(forrasstring, 1))) < 91 Then

            ws.Cells(sor, celoszlop) = Left(forrasstring, 2) ' Ha az első karakter betű, akkor úgy veszem, hogy a második is az. Enélkül túl bonyolult lenne

            forrasstring = Mid(forrasstring, 3)

        End If

        celoszlop = celoszlop + 1 ' Ha betű volt, akkor jó, egyébként a céloszlop üresen marad, és jön a következő

        If Not karkeres(forrasstring) Then Exit Do

        If Asc(Left(forrasstring, 1)) > 47 And Asc(Left(forrasstring, 1)) < 58 Then ' Ha szám

            adatstring = Left(forrasstring, 1)

            i = 2

            While Asc(Mid(forrasstring, i, 1)) > 47 And Asc(Mid(forrasstring, i, 2)) < 58 ' Amíg folyamatosan számok jönnek

                adatstring = adatstring & Mid(forrasstring, i, 1)

                i = i + 1

                If i > Len(forrasstring) Then forrasstring = forrasstring & " " ' Hogy ne akadjon ki

            Wend

            ws.Cells(sor, celoszlop) = adatstring

            forrasstring = Mid(forrasstring, i)

        End If

        celoszlop = celoszlop + 1

        If Not karkeres(forrasstring) Then Exit Do

        If Asc(UCase(Left(forrasstring, 1))) > 64 And Asc(UCase(Left(forrasstring, 1))) < 91 Then ' Ha karakter

            adatstring = Left(forrasstring, 1)

            i = 2

            While Asc(UCase(Mid(forrasstring, i, 1))) > 64 And Asc(UCase(Mid(forrasstring, i, 1))) < 91 ' Amíg folyamatosan betűk jönnek

                adatstring = adatstring & Mid(forrasstring, i, 1)

                i = i + 1

                If i > Len(forrasstring) Then forrasstring = forrasstring & " " ' Hogy ne akadjon ki

            Wend

            ws.Cells(sor, celoszlop) = adatstring

            forrasstring = Mid(forrasstring, i)

        End If

        celoszlop = celoszlop + 1

    Loop Until Len(forrasstring) = 0

'    Wend ' azután az egész kezdődik előlről, amíg van újabb tétel a sorban

Next sor

End Sub

Function karkeres(forrasstring) As Boolean

    karkeres = True

    While Not (Asc(UCase(Left(forrasstring, 1))) > 64 And Asc(UCase(Left(forrasstring, 1))) < 91 Or Asc(Left(forrasstring, 1)) > 47 And Asc(Left(forrasstring, 1)) < 58)

        forrasstring = Mid(forrasstring, 2) ' Ha nem karakter és nem szám, akkor töröljük

        If Len(forrasstring) = 0 Then

            karkeres = False ' Jelzi, hogy vége

            Exit Function

        End If

    Wend

End Function