Ausdrücke in Spalten aufteilen.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

…Werner;
gemeint hatte ich eher die fehlende LeerSpalte. Habe mir deshalb erlaubt, in die folgd Darstellung Deine Fml entsprd ergänzt, aber zwecks fairen Vgls ohne die primäre LeerZellenAbfrage, aufzunehmen:

O1.300Z100.a1

300

100

209 Zeichen

FINDEN, LINKS, RECHTS, SPALTE[8], TEIL[2], WECHSELN, WENN[2]

O1.400A1.1

400

7[16] Funktionen[einsätze]

O1.300Z100.a2

300

100

187 Zeichen

CountOn, MaskOn[3], VJoin, VSplit[3], WECHSELN[3], WIEDERHOLEN

O1.400A1.2

400

6[12] Funktionen[einsätze]

davon 4[8] UDF[-Einsätze]

O1.300Z100.b2

300

100

223 Zeichen

LÄNGE[2], MaskOn[4], VJoin, VSplit[3], WECHSELN[4], WIEDERHOLEN

O1.400B1.2

400

6[15] Funktionen[einsätze]

davon 3[8] UDF[-Einsätze]

O1.300Z100.a3

300

100

254 Zeichen

MaskOn[4], PickOn[7], VJoin, VSplit[2], WECHSELN[2]

O1.400A1.3

400

5[16] Funktionen[einsätze]

davon 4[14] UDF[-Einsätze]

B12[:I12;B13:I13]:=WENN(SPALTE(B12)=8;"";WECHSELN(WENN(SPALTE()<7;TEIL($A12;SPALTE(A12)+(SPALTE(A12)>3)*3;(SPALTE(A12)=3)*3+(SPALTE(A12)=5)*(FINDEN(".";TEIL($A12;8;6))-2)+1);LINKS(RECHTS($A12;9-SPALTE()+(SPALTE()>8));1));".";""))

B14:I14[;B15:I15]: {=VSplit(WECHSELN(WECHSELN(VJoin(VSplit(WECHSELN(MaskOn(A14;"alf");" ";" ";1)&WIEDERHOLEN(" ";2-CountOn(MaskOn(A14;"alf");" ")))&" "&VSplit(MaskOn(A14;"num")));" ";" ";1);" ";" ";6);;1)}

B16:I16[;B17:I17]: {=VSplit(WECHSELN(WECHSELN(VJoin(VSplit(WECHSELN(MaskOn(A16;"alf");" ";" ";1)&WIEDERHOLEN(" ";2-LÄNGE(MaskOn(A16;"alf"))+LÄNGE(WECHSELN(MaskOn(A16;"alf");" ";""))))&" "&VSplit(MaskOn(A16;"num")));" ";" ";1);" ";" ";6);;1)}

B18:I18[;B19:I19]: {=VSplit(VJoin(VSplit(PickOn(A18;1;".");"");" ")&" "&WECHSELN(PickOn(A18;2;".");MaskOn(PickOn(A18;2;".");"gb");" "&MaskOn(PickOn(A18;2;".");"gb")&" ")&" "&WECHSELN(PickOn(A18;3;".");MaskOn(PickOn(A18;3;".");"num");" "&MaskOn(PickOn(A18;3;".");"num"));;1)}

Während Deine Fml in B12:I13 natürlich eine zellenweise NormalFml ist, handelt es sich bei den 3 Fmln von mir um plurale MatrixFmln. Da immer auf die gleiche SpaltenAnzahl aufgeteilt wird, dürfte das ggf schneller und rationeller sein (auch etwas beim Anlegen). Durch Aufkopieren der Ergebnisse können die Werte ja auch vereinzelt wdn, wobei anschld auch gleich noch Spalte H gelöscht wdn kann, falls dort später anderes eingetragen wdn soll (nur vorher darf dort nichts stehen!).
Die Fmln in Zeile 16/17 entsprechen denen in 14/15, nur wurde hier CountOn durch das „klassische“ FmlKonstrukt ersetzt. Die Fmln in 18/19 zeigen dagg einen anderen Ansatz, der wohl leichter durchschaubar und ggf sicherer ist.
Allerdings müsste Deine Fml doch (deutlich) länger ausfallen, falls numerische Werte zu echten Zahlen wdn sollen… ;-)
UDF-Links:
CountOn: https://www.herber.de/forum/archiv/732to736/732035_Zaehlennwenn_mit_Zahlenkombinationen.html#734566
MaskOn: https://www.herber.de/cgi-bin/callthread.pl?index=1344962#1345181
PickOn: https://www.herber.de/forum/archiv/1140to1144/1141994_Teilstring_aus_String_entfernen.html#1142025 (Folgebeiträge m.Korrekturen beachten!)
VJoin & VSplit: https://www.herber.de/bbs/user/99024.xlsm (BspDatei)
Gruß, Luc :-?

…auch keinen entscheidenden Unterschied, Werner,
falls es nicht gerade um Massen-DV geht.
Tja, und was die VBA-Lösung betrifft, die hat er ja nun schon, was uns nicht daran hindern soll/kann, auch an einer FmlLösung für dieses kompliziertere Problem zu werken. Das könnte ggf für andere noch mal interessant wdn, obwohl (bzw gerade weil) die Aufgabe doch recht speziell ist. Aber nun sind wir wohl durch.
Übrigens musste ich auch ziemlich zirkeln, denn ältere UDFs von mir sind oft nicht aktiv mxfml-fähig, d.h., können keine ZellBereiche und Datenfelder verarbeiten, nur EinzelZellen und skalare Werte (wie hier bspw MaskOn). Das kann auch Datenfelder aus nur einem Wert betreffen, wie sie ZEILE bzw SPALTE einer EinzelZelle liefern. Sonst wären die Fmln wohl kürzer ausgefallen. Das würde ich wohl auch nur in Ausnahmefällen noch in neue Versionen dieser UDFs einbauen, da mir ja inzwischen Interessanteres vorschwebt, wie dieses FAN (Du erinnerst Dich!) und anderes, für das ich ebenfalls zu wenig Zeit habe…
Morrn, Luc :-?
PS: Habe zu Deiner AW im bewussten Thread (K-Donner) noch eine kleine OT(PS)-Replik geschrieben… ;-)

' ********************************************************************** ' Modul: Modul3 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub spiltText() Dim varInPut As Variant, varOutput() As Variant, varSplit As Variant Dim strTmp As String Dim lngI As Long On Error Resume Next With Sheets("Tabelle4") 'Tabellenname - Anpassen! varInPut = .Range("A12:A" & Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row)) Redim varOutput(1 To UBound(varInPut, 1), 1 To 8) For lngI = 1 To UBound(varInPut, 1) strTmp = Trim$(Replace(varInPut(lngI, 1), ".", " ")) If RXSplit(varSplit, strTmp, "\D+|\d+") = 0 Then varOutput(lngI, 1) = Trim$(varSplit(0)) varOutput(lngI, 2) = Trim$(varSplit(1)) varOutput(lngI, 3) = Trim$(varSplit(3)) varOutput(lngI, 4) = Trim$(varSplit(4)) varOutput(lngI, 5) = Trim$(varSplit(5)) varOutput(lngI, 6) = Trim$(varSplit(6)) varOutput(lngI, 8) = Trim$(varSplit(7)) End If Next .Range("A12").Resize(UBound(varOutput, 1), 8) = varOutput End With End Sub Private Function RXSplit(ByRef Result As Variant, Text As String, Pattern As String, Optional iCase As Boolean = True) As Long Dim objMatch As Object, lngI As Long, varTemp() As Variant Static objRegEX As Object On Error GoTo ErrorHandler If objRegEX Is Nothing Then Set objRegEX = CreateObject("VBScript.RegExp") objRegEX.Global = True objRegEX.MultiLine = True End If With objRegEX .IgnoreCase = iCase .Pattern = Pattern Set objMatch = .Execute(Text) Redim varTemp(objMatch.Count - 1) For lngI = 0 To objMatch.Count - 1 varTemp(lngI) = objMatch.Item(lngI) Next End With Result = varTemp Exit Function ErrorHandler: RXSplit = -1 End Function

' ********************************************************************** ' Modul: Modul3 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub spiltText() Dim varInPut As Variant, varOutput() As Variant, varSplit As Variant Dim objRange As Object Dim strTmp As String Dim lngI As Long On Error Resume Next With Sheets("Tabelle4") 'Tabellenname - Anpassen! Set objRange = .Range("A12:A" & Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row)) objRange.Interior.ColorIndex = xlNone varInPut = objRange Redim varOutput(1 To UBound(varInPut, 1), 1 To 8) For lngI = 1 To UBound(varInPut, 1) If RXCheck(varInPut(lngI, 1), "^\D+\d+\.\d+\D+\d+$|^\D+\d+\.\d+\D+\d+\.\D{1}\d*$") Then strTmp = Trim$(Replace(varInPut(lngI, 1), ".", " ")) If RXSplit(varSplit, strTmp, "\D+|\d+") = 0 Then varOutput(lngI, 1) = Trim$(varSplit(0)) varOutput(lngI, 2) = Trim$(varSplit(1)) varOutput(lngI, 3) = Trim$(varSplit(3)) varOutput(lngI, 4) = Trim$(varSplit(4)) varOutput(lngI, 5) = Trim$(varSplit(5)) varOutput(lngI, 6) = Trim$(varSplit(6)) varOutput(lngI, 8) = Trim$(varSplit(7)) End If Else varOutput(lngI, 1) = varInPut(lngI, 1) objRange.Cells(lngI, 1).Interior.Color = vbRed End If Next .Range("A12").Resize(UBound(varOutput, 1), 8) = varOutput End With Set objRange = Nothing End Sub Private Function RXSplit(ByRef Result As Variant, Text As String, Pattern As String, Optional iCase As Boolean = True) As Boolean Dim objMatch As Object, lngI As Long, varTemp() As Variant Static objRegEX As Object On Error GoTo ErrorHandler If objRegEX Is Nothing Then Set objRegEX = CreateObject("VBScript.RegExp") objRegEX.Global = True objRegEX.MultiLine = True End If With objRegEX .IgnoreCase = iCase .Pattern = Pattern Set objMatch = .Execute(Text) Redim varTemp(objMatch.Count - 1) For lngI = 0 To objMatch.Count - 1 varTemp(lngI) = objMatch.Item(lngI) Next End With Result = varTemp Exit Function ErrorHandler: RXSplit = -1 End Function Private Function RXCheck(ByVal Text As String, ByVal Pattern As String, Optional ByVal iCase As Boolean = True) As Boolean Static objRegEX As Object If objRegEX Is Nothing Then Set objRegEX = CreateObject("VBScript.RegExp") objRegEX.Global = True objRegEX.MultiLine = True End If With objRegEX .Global = True .IgnoreCase = iCase .Pattern = Pattern RXCheck = .test(Text) End With End Function

Sub Positionsnummer_prüfen() Dim varInPut As Variant, varOutput() As Variant, varSplit As Variant Dim objRange As Object Dim strTmp As String Dim lngI As Long On Error Resume Next Worksheets("Aufstellung").Range("B13:B" & Cells(Rows.Count, 1).End(xlUp).Row).Locked = True With Sheets("Aufstellung") 'Tabellenname - Anpassen! Set objRange = .Range("B13:B" & Application.Max(12, .Cells(.Rows.Count, 1).End(xlUp).Row)) objRange.Interior.ColorIndex = xlNone 'objRange.Font.Bold = False 'objRange.Font.ColorIndex = 1 varInPut = objRange ReDim varOutput(1 To UBound(varInPut, 1), 1 To 8) For lngI = 1 To UBound(varInPut, 1) If RXCheck(varInPut(lngI, 1), "^\D+\d+\.\d+\D+\d+$|^\D+\d+\.\d+\D+\d+\.\D{1}\d*$") Then strTmp = Trim$(Replace(varInPut(lngI, 1), ".", " ")) If RXSplit(varSplit, strTmp, "\D+|\d+") = 0 Then varOutput(lngI, 1) = Trim$(varSplit(0)) varOutput(lngI, 2) = Trim$(varSplit(1)) varOutput(lngI, 3) = Trim$(varSplit(3)) varOutput(lngI, 4) = Trim$(varSplit(4)) varOutput(lngI, 5) = Trim$(varSplit(5)) varOutput(lngI, 6) = Trim$(varSplit(6)) varOutput(lngI, 8) = Trim$(varSplit(7)) End If Else varOutput(lngI, 1) = varInPut(lngI, 1) objRange.Cells(lngI, 1).Interior.Color = vbRed 'objRange.Cells(lngI, 1).Font.Bold = True 'objRange.Cells(lngI, 1).Font.ColorIndex = 3 objRange.Cells(lngI, 1).Locked = False End If Next .Range("AO13").Resize(UBound(varOutput, 1), 8) = varOutput End With UserForm3.Show Set objRange = Nothing End Sub Private Function RXSplit(ByRef Result As Variant, Text As String, Pattern As String, Optional _ iCase As Boolean = True) As Boolean Dim objMatch As Object, lngI As Long, varTemp() As Variant Static objRegEX As Object On Error GoTo ErrorHandler If objRegEX Is Nothing Then Set objRegEX = CreateObject("VBScript.RegExp") objRegEX.Global = True objRegEX.MultiLine = True End If With objRegEX .ignorecase = iCase .Pattern = Pattern Set objMatch = .Execute(Text) ReDim varTemp(objMatch.Count - 1) For lngI = 0 To objMatch.Count - 1 varTemp(lngI) = objMatch.Item(lngI) Next End With Result = varTemp Exit Function ErrorHandler: RXSplit = -1 End Function Private Function RXCheck(ByVal Text As String, ByVal Pattern As String, Optional ByVal iCase As _ Boolean = True) As Boolean Static objRegEX As Object If objRegEX Is Nothing Then Set objRegEX = CreateObject("VBScript.RegExp") objRegEX.Global = True objRegEX.MultiLine = True End If With objRegEX .Global = True .ignorecase = iCase .Pattern = Pattern RXCheck = .test(Text) End With End Function

Sub Positionsnummer_prüfen() Dim varInPut As Variant, varOutput() As Variant, varSplit As Variant Dim objRange As Object, objError As Object Dim strTmp As String Dim lngI As Long On Error Resume Next With Sheets("Aufstellung") 'Tabellenname - Anpassen! Set objRange = .Range("B13:B" & Application.Max(13, .Cells(.Rows.Count, 2).End(xlUp).Row)) With objRange .Interior.ColorIndex = xlNone .Font.Bold = False .Font.ColorIndex = 1 .Locked = True End With varInPut = objRange Redim varOutput(1 To UBound(varInPut, 1), 1 To 8) For lngI = 1 To UBound(varInPut, 1) If RXCheck(varInPut(lngI, 1), "^\D+\d+\.\d+\D+\d+(\.\D{1}\d*)*$") Then strTmp = Trim$(Replace(varInPut(lngI, 1), ".", " ")) If RXSplit(varSplit, strTmp, "\D+|\d+") = 0 Then varOutput(lngI, 1) = Trim$(varSplit(0)) varOutput(lngI, 2) = Trim$(varSplit(1)) varOutput(lngI, 3) = Trim$(varSplit(3)) varOutput(lngI, 4) = Trim$(varSplit(4)) varOutput(lngI, 5) = Trim$(varSplit(5)) varOutput(lngI, 6) = Trim$(varSplit(6)) varOutput(lngI, 8) = Trim$(varSplit(7)) End If Else If objError Is Nothing Then Set objError = objRange.Cells(lngI, 1) Else Set objError = Union(objError, objRange.Cells(lngI, 1)) End If End If Next .Range("AO13").Resize(UBound(varOutput, 1), 8) = varOutput If Not objError Is Nothing Then With objError .Font.Bold = True .Font.ColorIndex = 3 .Locked = False End With End If End With UserForm3.Show Set objRange = Nothing Set objError = Nothing End Sub

Option Explicit Public Sub Aufteilen() Dim lZeile As Long Dim iSpalte As Integer Dim sText As Variant Dim lLaenge As Long Dim iPosition As Long Application.ScreenUpdating = False iSpalte = 2 With ThisWorkbook.Worksheets("Tabelle1") ' den tabellenblattnamen ggf. anpassen .Range("B2:I" & .Cells(.Rows.Count, 2).End(xlUp).Row).ClearContents For lZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row .Range("B" & lZeile).Value = Left(Range("A" & lZeile).Value, 1) .Range("C" & lZeile).Value = Mid(Range("A" & lZeile).Value, 2, 1) sText = "" For lLaenge = 4 To 7 If IsNumeric(Mid(.Range("A" & lZeile).Value, lLaenge, 1)) Then sText = sText + Mid(.Range("A" & lZeile).Value, lLaenge, 1) Else Exit For End If Next lLaenge .Range("D" & lZeile).Value = sText If Not IsNumeric(Mid(.Range("A" & lLaenge), 1, 1)) Then .Range("E" & lZeile).Value = Mid(Range("A" & lZeile).Value, lLaenge, 1) End If sText = "" iPosition = lLaenge + 1 For lLaenge = iPosition To 15 If IsNumeric(Mid(.Range("A" & lZeile).Value, lLaenge, 1)) Then sText = sText + Mid(.Range("A" & lZeile).Value, lLaenge, 1) Else Exit For End If Next lLaenge .Range("F" & lZeile).Value = sText iPosition = lLaenge + 1 If Not IsNumeric(Mid(.Range("A" & lZeile).Value, iPosition, 1)) Then .Range("G" & lZeile).Value = Mid(.Range("A" & lZeile).Value, iPosition, 1) End If .Range("H" & lZeile).Value = Right(.Range("A" & lZeile), 1) Next lZeile End With End Sub

Beliebteste Forumthreads (12 Monate)

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ausdrücke in Spalten aufteilen.

28 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread