@ Sepp: Daten auswerten

Hallo Sepp,
brauche wieder Deine Hilfe.
Ich kopiere aus einer Anwendung einen markierten Bereich in das erste Tabellenblatt (nur Spalte A ab Zeile 1).
Jetzt benötige ich aus dem Bereich alle Begriffe, die mit LV anfangen und dann eine maximal 9-stellige Nummer haben. Es können aber auch weniger sein. Nach der letzten Ziffer kommt ein Leerzeichen.
Ein Beispiel wie es aussieht. Der gesamte TExt befindet sich einer Zelle.
22.08.20 3 LV232346626 Test Korr. INÜ Claudia sdsadasdsadsadaddsdsadsad dasdasdasd
Jetzt bräuchte ich ein Makro was aus jeder Zelle den Begriff LV+Nummer in das zweite Tabellenblatt schreibt - also so: LV232346626
Da im Tabellenblatt auch leere Zeilen reinkopiert werden, wäre es sinnvoll, wenn ich den zu prüfenden Bereich manuell vorgeben kann.
Im zweiten Blatt sollen die Begriffe in Spalte untereinander aufgelistet werden.
Wäre das machbar?
Liebe Grüße
Claudia

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Claudia,
probiere mal diesen Code.


' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub extractLV()
  Dim rng As Range, rngSrc As Range, rngTgt As Range
  Dim strTmp As String, strPattern As String
  Dim vntExtract() As Variant
  Dim lngIndex As Long, lngStart As Long, lngEnd As Long
  
  strPattern = "LV+[0-9]{1,9}"
  
  On Error Resume Next
  Set rngSrc = Application.InputBox("Bitte wählen Sie den Quellbereich aus!", "Extract LV", Selection.Address, Type:=8)
  If rngSrc Is Nothing Then Exit Sub
  Set rngTgt = Application.InputBox("Bitte wählen Sie die Zielzelle aus!", "Extract LV", ActiveCell.Address, Type:=8)
  If rngTgt Is Nothing Then Exit Sub
  Err.Clear
  On Error GoTo 0
  
  For Each rng In rngSrc.Cells
    If rng <> "" Then
      strTmp = rng.Text
      lngStart = InStrREGEXP(strTmp, strPattern, True)
      If lngStart > 0 Then
        lngEnd = InStr(lngStart, strTmp, " ") - 1
        If lngEnd > lngStart Then
          Redim Preserve vntExtract(lngIndex)
          vntExtract(lngIndex) = Mid(strTmp, lngStart, lngEnd - lngStart + 1)
          lngIndex = lngIndex + 1
        End If
      End If
    End If
  Next
  
  If lngIndex > 0 Then
    rngTgt.Resize(UBound(vntExtract) + 1, 1) = Application.Transpose(vntExtract)
    Application.Goto rngTgt, True
  End If
  
  Set rngSrc = Nothing
  Set rngTgt = Nothing
  Set rng = Nothing
End Sub


Public Function InStrREGEXP(ByVal Text, ByVal Pattern, Optional ByVal IgnoreCase = False) As Long
  Dim objRegEx As Object, objM As Object, objMC As Object
  
  Set objRegEx = CreateObject("VBScript.RegExp")
  With objRegEx
    .Pattern = Pattern
    .IgnoreCase = IgnoreCase
    Set objMC = .Execute(Text)
    
    For Each objM In objMC
      InStrREGEXP = objM.Firstindex + 1
      Exit For
    Next
  End With
End Function

« Gruß Sepp »

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub extractLV() Dim rng As Range, rngSrc As Range, rngTgt As Range Dim strTmp As String, strPattern As String Dim vntExtract() As Variant Dim lngIndex As Long strPattern = "LV+[0-9]{1,9}" On Error Resume Next Set rngSrc = Application.InputBox("Bitte wählen Sie den Quellbereich aus!", "Extract LV", Selection.Address, Type:=8) If rngSrc Is Nothing Then Exit Sub Set rngTgt = Application.InputBox("Bitte wählen Sie die Zielzelle aus!", "Extract LV", ActiveCell.Address, Type:=8) If rngTgt Is Nothing Then Exit Sub Err.Clear On Error GoTo 0 For Each rng In rngSrc.Cells If rng <> "" Then strTmp = InStrREGEXP(rng.Text, strPattern, True, True) If strTmp <> "" Then Redim Preserve vntExtract(lngIndex) vntExtract(lngIndex) = strTmp lngIndex = lngIndex + 1 End If End If Next If lngIndex > 0 Then rngTgt.Resize(UBound(vntExtract) + 1, 1) = Application.Transpose(vntExtract) Application.Goto rngTgt, True End If Set rngSrc = Nothing Set rngTgt = Nothing Set rng = Nothing End Sub Public Function InStrREGEXP(ByVal Text, ByVal Pattern, Optional ByVal IgnoreCase = False, Optional ReturnString As Boolean = False) As Variant Dim objRegEx As Object, objM As Object, objMC As Object Set objRegEx = CreateObject("VBScript.RegExp") With objRegEx .Pattern = Pattern .IgnoreCase = IgnoreCase Set objMC = .Execute(Text) For Each objM In objMC If ReturnString Then InStrREGEXP = objM.Value Else InStrREGEXP = objM.Firstindex + 1 End If Exit For Next End With End Function

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

@ Sepp: Daten auswerten

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread