Thema Datum  Von Nutzer Rating
Antwort
04.03.2022 09:46:17 VBA_Beginner
NotSolved
04.03.2022 18:01:43 Gast8173
Solved
07.03.2022 06:53:05 Èintacht00
NotSolved
07.03.2022 07:12:57 Eintracht00
NotSolved
07.03.2022 18:33:00 Gast66835
NotSolved
Blau Text in Zelle aufsplitten und in gesonderte Zellen einfügen
08.03.2022 07:30:21 Eintracht00
NotSolved

Ansicht des Beitrags:
Von:
Eintracht00
Datum:
08.03.2022 07:30:21
Views:
838
Rating: Antwort:
  Ja
Thema:
Text in Zelle aufsplitten und in gesonderte Zellen einfügen

Hab mich zwar belesen aber mir sind einige Aspekte dennoch unschlüssig.. Aktuell bin ich soweit.. stimmt das ? / kann mir jemand helfen bei den Kommentaren wo noch Fragezeichen stehen

 

'************************************************************************************************************
' Namen der Parameter in einen regulären Ausdruck schreiben und darüber den dazugehörigen Wert auslesen     *
' ausgelesene Werte über ein Dictionary durchreichen                                                        *
' -> Felder werden passend mit Werten gefüllt, wenn gegeben                                                 *
'************************************************************************************************************

'Modul, durch welches alle Variablen explizit deklariert werden müssen -> wenn nicht, dann Kompilierungsfehler
Option Explicit
'Public Sub = kann von allen Modulen der Mappe/ Datei aufgerufen werden
Public Sub ExtractParamsFromClipboard()
      
'Variablendeklaration
  Dim rngParams As Excel.Range
  Dim strData As String
  Dim zeile As Long
  
'alle Parameter von Spalte A markieren
'letzte beschriebene Zeile ermitteln
  zeile = Range("A65536").End(xlUp).Row
'A1 bis letzter beschriebene Zeile in Spalte A markieren
  Range("A1:A" & zeile).Select

'Anzahl der Parameter durch Markierung in rngParams schreiben
  Set rngParams = Selection
   
'Rückgabewert von Funktion "GetClipboardTextData" in strData schreiben
  strData = GetClipboardTextData()
  
'Prüfen, ob Daten in Zwischenlage sind -> wenn nein, dann Fehlermeldung & Sub beenden
  If strData = "" Then
    Call MsgBox("Keine Daten in der Zwischenablage gefunden.", vbExclamation)
    Exit Sub
  End If
  
'Prüfen, ob mind. 2 Zellen/ Zeilen und maximal 1 Spalte markiert wurde -> wenn nein, dann Fehlermeldung & Sub beenden
  If rngParams.Cells.Count = 1 Or rngParams.Columns.Count > 1 Then
    Call MsgBox("Aktuelle Auswahl verletzt Kriterien:" _
                & vbNewLine & "Max-Spalten: 1, Min-Zellen: 2", _
                vbExclamation)
    Exit Sub
  End If
   
'Variablendeklaration
  Dim vntParam As Variant
  Dim dicParams As Object
    
'????
  Set dicParams = CreateObject("Scripting.Dictionary")
  For Each vntParam In rngParams.Cells
    dicParams(vntParam) = Empty
  Next
   
'Funktionsaufruf ExtractParams
  Call ExtractParams(strData, dicParams)
 
'????
  For Each vntParam In rngParams.Cells
    vntParam.Offset(0, 1).Value = dicParams(vntParam.Value)
  Next
   
'Message-Box sagt an, wenn Makro die Arbeit beendet hat
  Call MsgBox("Daten übermittelt.", vbInformation)
   
End Sub
'Private Sub ist nur im Projekt verfügbar, sprich nur auf dem Blatt
Private Sub ExtractParams(Expr As String, ByRef ParamDictionary As Object)
   
'Variablendeklaration
  Dim objMatch As Object
  Dim strPattern As String
   
'Regularen Ausdruck = Textuntersuchung
'Objekt mit Typ RegExp anlegen
  With CreateObject("VBScript.RegExp")
     
'ersten gefundenen Ausdruck wiedergeben, bei mehrfach matchen
    .Global = True
'Unterscheidung zwischen Groß- & Kleinschreibung
    .IgnoreCase = True
'Zeilenumbrüche im Suchstring = jeder Zeilenumbruch als einzelne Zeile betrachten
    .MultiLine = True
     
'Join = Eindimensionaler Array "ParamDictionary.Keys() zu einem String zusammenfügen
'ParamDictionary.Key() = gibt ein array aller "Keys" (Schlüssel in einem Dictionary-Objekt zurück
    strPattern = Join(ParamDictionary.Keys(), vbNullChar)
     
'Vergleichsmuster setzen
    .Pattern = "([-[\]{}()*+?.,\\^$|#\s])"
'Ersetzungen im Suchstring
    strPattern = .Replace(strPattern, "\$1")
    strPattern = Replace$(strPattern, vbNullChar, "|")
    strPattern = "(" & strPattern & ")\s+([^\r\n]+)"
'????
    .Pattern = strPattern
'????
    For Each objMatch In .Execute(Expr)
      ParamDictionary(objMatch.Submatches(0)) = objMatch.Submatches(1)
    Next
     
  End With
   
End Sub
'Funktonsdeklaration mit Rückgabewert als String
Public Function GetClipboardTextData() As String

'Legt fest, dass bei Auftreten eines Laufzeitfehlers die Steuerung zu der Anweisung geleitet wird, die unmittelbar auf die Anweisung folgt, bei der der Fehler aufgetreten ist und die Ausführung fortgesetzt wird.
  On Error Resume Next

'late Binding = no references (erhöht die Durchlaufgeschwindigkeit)
  With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

'Aufruf .GetFromClipboard = Inhalt der Zwischenablage mittels Daten-Objekt aufrufen
    Call .GetFromClipboard

'Text/ String aus der Zwischenablage holen und in GetClipboardTextData schreiben
    GetClipboardTextData = .GetText()
  End With
End Function
 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
04.03.2022 09:46:17 VBA_Beginner
NotSolved
04.03.2022 18:01:43 Gast8173
Solved
07.03.2022 06:53:05 Èintacht00
NotSolved
07.03.2022 07:12:57 Eintracht00
NotSolved
07.03.2022 18:33:00 Gast66835
NotSolved
Blau Text in Zelle aufsplitten und in gesonderte Zellen einfügen
08.03.2022 07:30:21 Eintracht00
NotSolved