Microsoft Excel

Herbers Excel/VBA-Archiv

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Informationen und Beispiele zum Thema Werkzeug
BildScreenshot zu Werkzeug Werkzeug-Seite mit Beispielarbeitsmappe aufrufen

Hilfe für VBA-Script "Extrahieren"

Betrifft: Hilfe für VBA-Script "Extrahieren" von: stormlamp
Geschrieben am: 10.08.2014 10:58:38

Hallo Zusammen,

hier im Forum habe ich von JoWE ein VBA-Scrpt bekommen, das eigentlich super läuft, aber noch 3 Probleme hat. Vielleicht kann mir noch ein Spezialist helfen, da ich als VBA-Anfänger das Script nicht verstehe, geschweige denn, ändern kann.

Die Probleme kommen daher, weil ich meine Definitionen nicht sauber genug gestellt hatte - mea culpa.

Aufgabenstellung:
Aus Zellen einer Spalte, in der gerade der Cursor steht, die den Begriff "DIN" enthalten, soll das Wort, das den Teilstring "DIN" enthält inklusive des folgenden Wortes, soweit es ein weiteres wort gibt, in die benachbarte Zelle rechts übertragen werden.

Hier die Beispiele mit den gewünschten Ergebnissen:
1 - "Strukturteil DIN4711A" -> "DIN4711A"
2 - "Strukturteil DIN-4711A test" -> "DIN-4711A"
3 - "xxx DIN 123 xxx" -> "DIN 123"
4 - "din 345" -> "din 345"
5 - "DIN 123 xxx" -> "DIN 123"
6 - "DIN-123 xxx" -> "DIN-123"
7 - "xxx DIN123" ->"DIN123"
8 - "DIN123 " "->"DIN123"
9 - "xxx DIN-123/XX xxx" ->DIN-123/XX"
10 - "xxx DIN/ISO 781 xxx" ->DIN/ISO 781"
11 - "hallo" -> leer
12 - "DIN 789" -> "DIN 789"

Probleme im nachfolgenden Script:
1. Beispiel 11: Sobald eine Zelle den Begriff "DIN" nicht enthält, kommt eine Fehlermeldung, statt dass die zelle übersprungen wird
2. Beispiel 4 funktioniert nicht, weil nicht alles Großbuchstaben sind, es sollte auch bei kleinen Buchstaben und gemischter Schreibweise funktionieren
3. Beispiel 12: Sobald hinter dem 2. Wort kein Leerzeichen ist, funktioniert es nicht

Vielleicht kann mir jemand helfen, im Anhang das bisherige Script
Mit freundlichen Grüßen
Hans
------------------------

Sub extrahiere_DINISO()
      Dim i As Long, c As Long
      Dim sh As Worksheet
      c = ActiveCell.Column
      Set sh = ActiveSheet
      With sh
          For i = ActiveCell.Row To .Cells(.Rows.Count, c).End(xlUp).Row
              Cells(i, c + 1) = Mid(Cells(i, c), InStr(1, .Cells(i, c), "DIN"), 99)
              If InStr(1, Cells(i, c + 1), " ") > 0 Then
                  Cells(i, c + 1) = Left(Cells(i, c + 1), InStr(InStr(1, Cells(i, c + 1), _
                  NumberExtract(CStr(Cells(i, c + 1)))) + 2, Cells(i, c + 1), " "))
              End If
          Next
      End With
  End Sub

-----------------------------
Function NumberExtract(ByVal strData As String, Optional ByVal lngPos As Long = 1) As Double
      'Dank an Office-Loesung.de (Autor: Phelan XLPH)
      Dim i As Long, strNumber As String, blnNumber As Boolean
         For i = 1 To Len(strData)
            If IsNumeric(Mid$(strData, i, 1)) Then
               strNumber = strNumber & Mid$(strData, i, 1)
               blnNumber = True
            ElseIf blnNumber Then
               strNumber = strNumber & ";"
               blnNumber = False
            End If
         Next
         NumberExtract = CDbl(Split(strNumber, ";")(lngPos - 1))
  End Function

  

Betrifft: (DIN|din)([ \\\/-]?\d+([A-Z]|\/[A-Z])*|\/ISO \d+) von: ransi
Geschrieben am: 10.08.2014 12:22:34

Hallo Hans

Ich denke das ist eher etwas für reguläre Ausdrücke. Nennt man auch Regexp.
Regexp ist nicht ganz trivial, aber ein mächtiges Werkzeug um Strings zu untersuchen.

Teste mal dies:
Tabelle1

 AB
11 - "Strukturteil DIN4711" -> "DIN4711"DIN4711
22 - "Strukturteil DIN-4711A test" -> "DIN-4711A"DIN-4711A
33 - "xxx DIN 123 xxx" -> "DIN 123"DIN 123
44 - "din 345" -> "din 345"din 345
55 - "DIN 123 xxx" -> "DIN 123"DIN 123
66 - "DIN-123 xxx" -> "DIN-123"DIN-123
77 - "xxx DIN123" ->"DIN123"DIN123
88 - "DIN123 " "->"DIN123"DIN123
99 - "xxx DIN-123/XX xxx" ->DIN-123/XX"DIN-123/XX
1010 - "xxx DIN/ISO 781 xxx" ->DIN/ISO 781"DIN/ISO 781
1111 - "hallo" -> leer 
1212 - "DIN 789" -> "DIN 789"DIN 789
13  
14  

Formeln der Tabelle
ZelleFormel
B1=extract_was(A1)


Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4


Dazu diesen Code in ein Modul:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit



Public Function extract_was(zelle)
    Dim Regex As Object
    Set Regex = CreateObject("VbScript.Regexp")
    extract_was = ""
    With Regex
        .ignorecase = False 'GROSS-kleinschreibung beachten
        .Pattern = "(DIN|din)([ \\\/-]?\d+([A-Z]|\/[A-Z])*|\/ISO \d+)"
        If .test(zelle.Text) = True Then
            extract_was = .Execute(zelle.Text)(0).Value
        End If
    End With
End Function



Wenn da noch mehr Schreibweisen auftauchen melde dich. Dann muss man das Pattern anpassen.

ransi


  

Betrifft: AW: (DIN|din)([ \\\/-]?\d+([A-Z]|\/[A-Z])*|\/ISO \d+) von: stormlamp
Geschrieben am: 10.08.2014 12:37:53

Hallo ransi,

vielen Dank für das Modul mit der mir unbekannten Funktion Regex. Alle Inhalte werden aus den Beispielen richtig extrahiert.

Kann man das Modul auch in ein Makro einbauen, das in der aktuellen Spalte ab Cursorposition nach unten alle Zellen bearbeitet und das Ergebnis jeweils in die Zelle rechts daneben schreibt?

Mit freundlichen Grüßen
Hans


  

Betrifft: Schleife drumrum ;-) von: ransi
Geschrieben am: 10.08.2014 12:56:04

Hallo

Da musst du nur eine Schleife um die entsprechenden Zellen drumrumbinden.
Schau es dir mal an:

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

Option Explicit

Sub Aufruf()
    Dim Bereich As Range
    Dim myRng As Range
    With ActiveCell
        Set Bereich = Range(Cells(.Row, .Column), Cells(Rows.Count, .Column).End(xlUp))
    End With
    
    For Each myRng In Bereich.Cells
        myRng.Offset(0, 1) = extract_was(myRng)
    Next
    
End Sub


Public Function extract_was(zelle)
    Dim Regex As Object
    Set Regex = CreateObject("VbScript.Regexp")
    extract_was = ""
    With Regex
        .ignorecase = False 'GROSS-kleinschreibung beachten
        .Pattern = "(DIN|din)([ \\\/-]?\d+([A-Z]|\/[A-Z])*|\/ISO \d+)"
        If .test(zelle.Text) = True Then
            extract_was = .Execute(zelle.Text)(0).Value
        End If
    End With
End Function



ransi


  

Betrifft: AW: Schleife drumrum ;-) von: stormlamp
Geschrieben am: 10.08.2014 13:47:32

Hallo ransi,

vielen Dank, perfekt, läuft genauso ab, wie gewünscht!

Schönen Sonntagnachmittag
Hans