Ausdrücke in Spalten aufteilen.

Jens · 2017-08-27T11:02:16+00:00

Hallo, wie würde gerne Ausdrücke in Spalten autteilen. Die Ausdrücke sehen so aus und stehen ab Zelle B12. (Ende nach unten offen) O1.300Z100.a1 O1.400A1.1 Es sollen dabei die Buchstabenblöcke und Ziffernblöcke in je einzele Spalten zerlegt werden. Der Punkt agiert dabei wieder als Vorgabe zu einer neuen Spalte Spalte B: O Spalte C: 1 Spalte D: 300 Spalte E: Z Spalte F: 100 Spalte G: a Spalte I: 1 Bzw. Spalte B: O Spalte C: 1 Spalte D: 400 Spalte E: A Spalte F: 1 Spalte G: Spalte I: 1 Nach dem zweiten Punkt muss es so sein, dass die Buchstaben in Spalte G und die Ziffern in Spalte I geschrieben werden. Kann mir hierzu wer weiterhelfen?

…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 :-?

Hallo Sepp,
habe das Problem, dass die Datei sehr groß ist und dadurch sehr überladen mit den roten zellen.
Hätte versucht jetzt die Schrift Fett und die schriftfarbe rot zu machen.
Wir auch gemacht aber am Ende des makros wird wieder alles zurück gesetzt. Kannst du mir hier nochmals helfen?
in Spalten aufteilen.


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

Forumthread: Ausdrücke in Spalten aufteilen.

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Ausdrücke in Spalten aufteilen.

Forumthread: Ausdrücke in Spalten aufteilen.

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread