Inhalte mit gleichenr Buchstabenfolge aus Spalte in Zeilen kopieren

[LegrandS]

Hallo Experten

Ich möchte aus nur einer Spalte (H) die gesamten Wörter in Zeilen kopieren wobei in einer Zeile immer die Wörter stehen bei denen die ersten 3 Anfangsbuchstaben gleich sind.

Beispiel: In Spalte H stehen die Wörter
FRD001
FRD003
FRD005
FRD007
JUG003
JUG005
JUG006
KIM001
STD005
STD006

und sollen dann so aussehen
Jedes für sich in einer eigen Zelle
Zeile1: FRD001 FRD003 FRD005 FRD007
Zeile2: JUG003 JUG005 JUG006
Zeile3: KIM001
Zeile4: STD005 STD006
usw.
Ich hoffe das ist so verständlich und es eine Lösung mit VBA gibt

Grüße LegrandS

[snb]

Wozu ?

[EA1950]

Hallo,

du hast als Excelversion "Excel xp" - also eine Uraltversion.

Bei einem Excel365 wäre die Sache ganz einfach - durch eine einzige Formel lösbar:
=LET(m;$A$1:.$A$99; g;GRUPPIERENNACH(LINKS(m; 3); m;MATRIXZUTEXT; ; 0); t;TEXTVERKETTEN("|"; 1; SPALTENWAHL(g; 2)); WENNFEHLER(TEXTTEILEN(t; "; "; "|"); ""))

[OnlineExcel]

Hallo Experten

Ich möchte aus nur einer Spalte (H) die gesamten Wörter in Zeilen kopieren wobei in einer Zeile immer die Wörter stehen bei denen die ersten 3 Anfangsbuchstaben gleich sind.

Beispiel: In Spalte H stehen die Wörter
FRD001
FRD003
FRD005
FRD007
JUG003
JUG005
JUG006
KIM001
STD005
STD006

und sollen dann so aussehen
Jedes für sich in einer eigen Zelle
Zeile1: FRD001 FRD003 FRD005 FRD007
Zeile2: JUG003 JUG005 JUG006
Zeile3: KIM001
Zeile4: STD005 STD006
usw.
Ich hoffe das ist so verständlich und es eine Lösung mit VBA gibt

Grüße LegrandS

Auf die Schnelle, anpassen!
Sollte in jeder Excelversion fuktionieren - aber selber testen macht  schön

Code:

Sub Tues()
    Const startCol As Long = 12 ' anpassen
    Dim dict As Object, dict2 As Object, z As Long, col As Long, row As Long
    Dim i As Long, s As String
    Dim v As Variant
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    Set dict2 = CreateObject("Scripting.Dictionary")
    v = ws.Range("H1:H10").Value ' anpassen
    For i = 1 To UBound(v)
        s = Left$(v(i, 1), 3)
        If dict.Exists(s) Then
            row = dict(s)
            col = dict2(s)
            ws.Cells(row, col).Value = v(i, 1)
            dict2(s) = col + 1
        Else
            z = z + 1
            ws.Cells(z, startCol).Value = v(i, 1)
            dict.Add s, z
            dict2.Add s, startCol + 1
        End If
    Next i
End Sub

Gruß P

[LegrandS]

Lieber P

Das ist Es.
Vielen lieben Dank für die schnelle Lösung.

Liebe Grüße LegrandS

[LegrandS]

Hallo P

Im bitte um Entschuldigung!
Ich hab nicht weit genug gedacht und was vergessen.
Wenn es in der Zeile mehr als 6 Zellen sind bei gleichen 3 Anfangsbuchstaben dann soll es in der nächsten Zeile weitergehen. (Zeilenumbruch)
Blöder Fehler von mir.

In stiller Hoffnung auf eine Lösung

liebe Grüße
LegrandS

[Kuwer]

Hallo LegrandS,

teste mal das:

Code:

Sub ccc()
  Dim i As Long, x As Long, y As Long
  Dim vQ As Variant, vZ As Variant
  Dim strT As String
  vQ = Range(Cells(1, 8), Cells(Rows.Count, 8).End(xlUp)).Value
  ReDim vZ(1 To UBound(vQ), 1 To 6)
  For i = 1 To UBound(vQ)
    If strT <> Left(vQ(i, 1), 3) Then
      strT = Left(vQ(i, 1), 3)
      x = x + 1
      y = 1
    Else
      y = y + 1
      If y > UBound(vZ, 2) Then
        x = x + 1
        y = 1
      End If
    End If
    vZ(x, y) = vQ(i, 1)
  Next i
  Cells(1, 11).Resize(UBound(vZ, 1), UBound(vZ, 2)).Value = vZ
End Sub

Gruß, Uwe

[Egon12]

Hallo LegrandS,

bei > 6 identischer Buchstabenfolge Zeilenumbruch in Zellen oder eine neue Zeile.
Da braucht es schon eine klare Aussage.

Gruß Uwe

---

für den Fall, dass es sich tatsächlich um einen Zeilenumbruch und nicht um eine neue Zeile im Tabellenblatt handelt wäre dies einer der vielen möglichen Wege:

Code:

Option Explicit

Sub zuordnen()
    Dim i&, j&, k&, r&, tmp, objDict As Object, arr(), arrList(): arr = Tabelle1.Range("H2:H" & Tabelle1.Cells(Rows.Count, 8).End(xlUp).Row)
    Set objDict = CreateObject("Scripting.Dictionary")
    For i = LBound(arr) To UBound(arr)
        objDict(Left(arr(i, 1), 3)) = 0
    Next i
    tmp = objDict.keys
    ReDim arrList(1 To UBound(tmp) + 1, 1 To 1000)
    For i = 0 To objDict.Count - 1
        For j = LBound(arr) To UBound(arr)
            If InStr(1, arr(j, 1), tmp(i), vbTextCompare) > 0 Then
                k = k + 1
                If k <= 6 Then
                    arrList(i + 1, k) = arr(j, 1)
                Else
                    If r = 6 Then r = 0
                    If r <= 6 Then
                        r = r + 1
                        arrList(i + 1, r) = arrList(i + 1, r) & vbCrLf & arr(j, 1)
                    Else
                        r = 0
                    End If
                End If
            End If
        Next j
        If k > r Then r = k
        k = 0
    Next i
    Range("J1").Resize(UBound(arrList), r) = arrList
End Sub

Gruß Uwe

[snb]

Code:

Sub M_snb()
  sn = Filter(Application.Transpose(Cells(1).CurrentRegion), "")

  Do
    st = Filter(sn, Left(sn(0), 3))
    For j = 0 To UBound(st)
        If j Mod 6 = 0 Then y = Cells(Rows.Count, 3).End(xlUp).Offset(1).Row
        Cells(y, j Mod 6 + 3) = st(j)
    Next
    sn = Filter(sn, Left(sn(0), 3), 0)
  Loop Until UBound(sn) = -1
End Sub

Interaktion mit dem Arbeitsblatt reduziert:

Code:

Sub M_snb()
  sn = Filter(Application.Transpose(Cells(1).CurrentRegion), "")
  ReDim sp(UBound(sn) + 1, 6)
  y = -1
  
  Do
    st = Filter(sn, Left(sn(0), 3))
    For j = 0 To UBound(st)
      If j Mod 6 = 0 Then y = y + 1
      sp(y, j Mod 6) = st(j)
    Next
    sn = Filter(sn, Left(sn(0), 3), 0)
  Loop Until UBound(sn) = -1
  
  Cells(1, 3).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

[LegrandS]

Vielen Dank euch Allen für eure Mühe.

Die Lösung von "Kuwer" entsprach genau dem was ich suchte und brauchte

Nochmals Dank an Alle.

Grüße
Legrand