@ Sepp: Daten auswerten

Forumthread: @ Sepp: Daten auswerten

Claudia

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

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

AW: @ Sepp: Daten auswerten

Josef
Noch etwas vereinfacht!

Josef
WOW, das funktioniert wie

Claudia

AW: @ Sepp: Daten auswerten

23.10.2011 16:20:02

Josef

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 »

Noch etwas vereinfacht!

23.10.2011 16:33:03

Josef


' **********************************************************************
' 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

« Gruß Sepp »

WOW, das funktioniert wie

23.10.2011 17:13:45

Claudia

geschmiert und erleichtert mir die Arbeit.
Vielen lieben Dank, Sepp! :-)

Beliebteste Forumthreads (12 Monate)

Forumthread: @ Sepp: Daten auswerten

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread