VBA: Textsuche und aufsplitten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Normen() Dim lZ As Long, i As Integer, j As Long, k As Long, strTmp lZ = Range("A" & Rows.Count).End(xlUp).Row For j = 2 To lZ strTmp = Split(Range("A" & j), " ") k = 4 For i = 1 To UBound(strTmp) If strTmp(i) = "ISO" Or strTmp(i) = "DIN" Then Cells(j, k) = strTmp(i) & " " & strTmp(i + 1) k = k + 1 End If Next i Next j End Sub

Option Explicit Sub splitText() Dim varSearch As Variant, varText As Variant, varResult() As Variant Dim lngIndex As Long, lngN As Long, lngPos As Long, lngEnd As Long, lngM As Long varSearch = Array("DIN", "ISO") 'gesuchte Normen-Kürzel With Sheets("Tabelle1") varText = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) Redim varResult(1 To Ubound(varText, 1), 1 To 20) For lngIndex = 1 To Ubound(varText, 1) lngPos = 0 lngM = 0 For lngN = Lbound(varSearch) To Ubound(varSearch) Do lngPos = InStr(lngPos + 1, varText(lngIndex, 1), varSearch(lngN), vbTextCompare) lngEnd = InStr(lngPos + Len(varSearch(lngN)) + 1, varText(lngIndex, 1), " ", vbTextCompare) If lngPos > 0 And lngEnd > 0 Then lngM = lngM + 1 varResult(lngIndex, lngM) = Mid(varText(lngIndex, 1), lngPos, lngEnd - lngPos) lngPos = lngEnd + 1 End If Loop While lngPos > 0 Next Next .Range("B2").Resize(Ubound(varResult, 1), Ubound(varResult, 2)) = varResult End With End Sub VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

Hallo Bernd,
so ist der Code noch etwas robuster.
Modul Modul1

Option Explicit 
 
Sub splitText() 
  Dim varSearch As Variant, varText As Variant, varResult() As Variant 
  Dim lngIndex As Long, lngN As Long, lngPos As Long, lngEnd As Long, lngM As Long 
  Dim rngRow As Range 
   
  With Sheets("Tabelle1") 
    varText = .Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) 
    Redim varResult(1 To Ubound(varText, 1), 1 To 20) 
    For lngIndex = 1 To Ubound(varText, 1) 
      varSearch = Split(varText(lngIndex, 2), ";") 
      lngPos = 0 
      lngM = 0 
      For lngN = Lbound(varSearch) To Ubound(varSearch) 
        Do 
          lngPos = InStr(lngPos + 1, varText(lngIndex, 1), Trim(varSearch(lngN)), vbTextCompare) 
          lngEnd = InStr(lngPos + Len(Trim(varSearch(lngN))) + IIf(InStr(1, Trim(varSearch(lngN)), " "), 0, 1), _
            varText(lngIndex, 1), " ", vbTextCompare) 
          If lngPos > 0 And lngEnd > 0 Then 
            lngM = lngM + 1 
            varResult(lngIndex, lngM) = Mid(varText(lngIndex, 1), lngPos, lngEnd - lngPos) 
            lngPos = lngEnd + 1 
          End If 
        Loop While lngPos > 0 
      Next 
    Next 
    With .Range("D2").Resize(Ubound(varResult, 1), Ubound(varResult, 2)) 
      .Value = varResult 
      For Each rngRow In .Rows 
        rngRow.Sort Key1:=rngRow.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlSortRows 
      Next 
    End With 
  End With 
 
End Sub 
 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

	A	B	C	D	E	F
1	Gruß Sepp
2
3

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Textsuche und aufsplitten

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread