Spalten sortieren

[hubsi]

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

[Kuwer]

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

[snb]

Bitte, verwende Code Tags.


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