Clever-Excel-Forum

(27.02.2020, 09:15)Kuwer schrieb: [ -> ]Hallo,

teste es mal damit:

Sub TextInSpaltenMitZuordnung_3()

  Dim i As Long, j As Long, k As Long, l As Long

  Dim rngB As Range

  Dim strTemp As String

  Dim varT As Variant, varS As Variant

  Dim varQ As Variant, varZ As Variant

  Dim colSpalten As New Collection

  

  Set rngB = Cells(1).CurrentRegion.Columns(2)

  varQ = rngB.Value

  ReDim varZ(1 To 1, 1 To Application.CountIf(rngB, "*:*") / 2)

  

  On Error Resume Next

  l = 1

  For i = 2 To UBound(varQ)

    varT = Split(varQ(i, 1), "|")

    For j = 0 To UBound(varT)

      varS = Split(varT(j), ": ")

      For k = 0 To 0

        colSpalten.Add CStr(l), CStr(varS(k))

        If Err.Number Then

          Err.Clear

        Else

          varZ(1, l) = varS(k)

          l = l + 1

        End If

      Next k

    Next j

  Next i

  On Error GoTo 0

  

  Cells(1, 2).Resize(1, l).Value = varZ

  

  ReDim varZ(1 To rngB.Rows.Count, 1 To l)

  

  For i = 2 To UBound(varQ)

    varT = Split(varQ(i, 1), "|")

    For j = 1 To UBound(varT)

      varS = Split(varT(j), ": ")

      For k = 0 To 0

        For l = 2 To UBound(varS)

          strTemp = strTemp & ": " & varS(l)

        Next l

        For l = 1 To UBound(varS)

          varZ(i - 1, colSpalten(varS(k))) = "'" & varS(l) & strTemp

          Exit For

        Next l

        strTemp = ""

      Next k

    Next j

  Next i

  

  Cells(1, 2).Resize(UBound(varZ, 1), UBound(varZ, 2)).Offset(1).Value = varZ

  Cells(1).CurrentRegion.Columns.AutoFit

  Cells(1).CurrentRegion.Rows.AutoFit

End Sub

Gruß Uwe

Hallo Kuwer,

vielen Dank für deinen Code - dieser hat funktioniert. Nur den ersten Wert in der Spalte technische Details wird nicht zugeordnet. Siehe Link - hast du eine Idee warum das so ist?

[Bild: 135560.jpg]

Grüße, Markmüller

Hallo hubsi,

da hatte sich eine 1 statt einer 0 eingeschlichen.
Ist jetzt korrigiert (rot gekennzeichnet):

Sub TextInSpaltenMitZuordnung_4()

  Dim i As Long, j As Long, k As Long, l As Long

  Dim rngB As Range

  Dim strTemp As String

  Dim varT As Variant, varS As Variant

  Dim varQ As Variant, varZ As Variant

  Dim colSpalten As New Collection

  

  Set rngB = Cells(1).CurrentRegion.Columns(2)

  varQ = rngB.Value

  ReDim varZ(1 To 1, 1 To Application.CountIf(rngB, "*:*") / 2)

  

  On Error Resume Next

  l = 1

  For i = 2 To UBound(varQ)

    varT = Split(varQ(i, 1), "|")

    For j = 0 To UBound(varT)

      varS = Split(varT(j), ": ")

      For k = 0 To 0

        colSpalten.Add CStr(l), CStr(varS(k))

        If Err.Number Then

          Err.Clear

        Else

          varZ(1, l) = varS(k)

          l = l + 1

        End If

      Next k

    Next j

  Next i

  On Error GoTo 0

  

  Cells(1, 2).Resize(1, l).Value = varZ

  

  ReDim varZ(1 To rngB.Rows.Count, 1 To l)

  

  For i = 2 To UBound(varQ)

    varT = Split(varQ(i, 1), "|")

    For j = 0 To UBound(varT)

      varS = Split(varT(j), ": ")

      For k = 0 To 0

        For l = 2 To UBound(varS)

          strTemp = strTemp & ": " & varS(l)

        Next l

        For l = 1 To UBound(varS)

          varZ(i - 1, colSpalten(varS(k))) = "'" & varS(l) & strTemp

          Exit For

        Next l

        strTemp = ""

      Next k

    Next j

  Next i

  

  Cells(1, 2).Resize(UBound(varZ, 1), UBound(varZ, 2)).Offset(1).Value = varZ

  Cells(1).CurrentRegion.Columns.AutoFit

  Cells(1).CurrentRegion.Rows.AutoFit

End Sub

Gruß Uwe

Bitte, verwende Code Tags.


Hast du https://www.clever-excel-forum.de/Thread...#pid189866 übersehen ?