Office: VBA Code erweitern

Helfe beim Thema VBA Code erweitern in Microsoft Excel Hilfe um das Problem gemeinsam zu lösen; Hallo zusammen, ich habe ein Problem in Excel mit einem VBA Code. In Spalte A habe ich Langtexte und in Spalte B habe ich dazu eine passende... Dieses Thema im Forum "Microsoft Excel Hilfe" wurde erstellt von BePe82, 12. Januar 2023.

  1. BePe82 Neuer User

    VBA Code erweitern


    Hallo zusammen,

    ich habe ein Problem in Excel mit einem VBA Code.
    In Spalte A habe ich Langtexte und in Spalte B habe ich dazu eine passende Abkürzung.
    Wenn ich in E5 "mehrere" Wörter schreibe kommt da drunter dann die passende Abkürzung.
    Aktuell ist der Code halt auf Eingabe E5 und Ausgabe E6 und E7 begrenzt.
    Mein Wunsch wäre jetzt das ich von E5 bis E25 die Eingabe machen kann und dann jeweils rechts daneben (F5 bis F25) die Ausgabe bekomme.
    Wie kann der VBA Code entsprechend angepasst / erweitert werden, damit ich nicht immer nur einen Text abkürzen kann?
    VBA Code erweitern 1-Annotation-2023-01-11-091424.png
    VBA Code erweitern 2-Annotation-2023-01-11-091647.png
    .
    Viele Grüße
    BePe
     
  2. BePe82 Neuer User
    Option Explicit

    Dim AllLText As Variant
    Dim iLText, KText, AllKText(), AText, AllAText, i, Ergebnis, ZelleErgebnis


    Private Sub Worksheet_Change(ByVal Target As Range)

    'Änderung in der Abkürzungsliste
    If Target.Address = "$E$5" Then
    'Es erfolgt ein Eintrag in Langbezeichnung
    AllLText = Split(Range("$E$5"), " ")

    'Zählen der Wörter
    i = 0
    For Each iLText In AllLText
    i = i + 1
    Next

    If Range("E5").Value <> "" Then 'Es ist kein Wert eingetragen
    ReDim AllKText(i - 1)
    ReDim AllAText(i - 1)
    i = 0
    For Each iLText In AllLText
    i = i + 1

    'Langtext finden
    Set Ergebnis = ActiveSheet.Range("A1:A40000").Find(What:=iLText, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not Ergebnis Is Nothing Then
    ZelleErgebnis = Ergebnis.Address

    'Abkürzung ermitteln
    Range(ZelleErgebnis).Activate
    ActiveCell.Offset(0, 1).Activate
    AllKText(i - 1) = ActiveCell.Value
    ActiveCell.Offset(0, 1).Activate
    AllAText(i - 1) = ActiveCell.Value

    Else
    AllKText(i - 1) = iLText
    AllAText(i - 1) = ""
    End If
    Next

    KText = Join(AllKText, " ")
    AText = Join(AllAText, " ")

    'ActiveSheet.Unprotect ""
    ActiveSheet.Range("F5").Value = KText
    ActiveSheet.Range("G5").Value = AText
    ActiveSheet.Range("E5").Activate
    'ActiveSheet.Protect ""
    Else
    'ActiveSheet.Unprotect ""
    ActiveSheet.Range("E6").Value = ""
    'ActiveSheet.Protect ""
    End If
    End If

    End Sub

    Option Explicit

    Dim AllLText As Variant
    Dim iLText, KText, AllKText(), AText, AllAText, i, Ergebnis, ZelleErgebnis


    Private Sub Worksheet_Change2(ByVal Target As Range)

    'Änderung in der Abkürzungsliste
    If Target.Address = "$E$6" Then
    'Es erfolgt ein Eintrag in Langbezeichnung
    AllLText = Split(Range("$E$6"), " ")

    'Zählen der Wörter
    i = 0
    For Each iLText In AllLText
    i = i + 1
    Next

    If Range("E6").Value <> "" Then 'Es ist kein Wert eingetragen
    ReDim AllKText(i - 1)
    ReDim AllAText(i - 1)
    i = 0
    For Each iLText In AllLText
    i = i + 1

    'Langtext finden
    Set Ergebnis = ActiveSheet.Range("A1:A40000").Find(What:=iLText, _
    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not Ergebnis Is Nothing Then
    ZelleErgebnis = Ergebnis.Address

    'Abkürzung ermitteln
    Range(ZelleErgebnis).Activate
    ActiveCell.Offset(0, 1).Activate
    AllKText(i - 1) = ActiveCell.Value
    ActiveCell.Offset(0, 1).Activate
    AllAText(i - 1) = ActiveCell.Value

    Else
    AllKText(i - 1) = iLText
    AllAText(i - 1) = ""
    End If
    Next

    KText = Join(AllKText, " ")
    AText = Join(AllAText, " ")

    'ActiveSheet.Unprotect ""
    ActiveSheet.Range("F6").Value = KText
    ActiveSheet.Range("G6").Value = AText
    ActiveSheet.Range("E6").Activate
    'ActiveSheet.Protect ""
    Else
    'ActiveSheet.Unprotect ""
    ActiveSheet.Range("E6").Value = ""
    'ActiveSheet.Protect ""
    End If
    End If

    End Sub
     
  3. Klaus-Dieter Erfahrener User
    Hallo,

    stelle doch bitte eine Beispieldatei ein, das erhöht die Change auf Lösungsvorschläge ganz erheblich.
     
    Klaus-Dieter, 12. Januar 2023
    #3
  4. BePe82 Neuer User

    VBA Code erweitern

    Stimmt :-)
    Hier die Datei.
    Danke das du dir das mal anschaust.
     
  5. Exl121150 Erfahrener User
    Hallo,

    habe dir ein Suchmakro eingefügt. Deine Suchtabelle habe ich in eine strukturierte Tabelle namens "tbVerzeichnis" umgewandelt.
     
    Exl121150, 12. Januar 2023
    #5
    1 Person gefällt das.
  6. BePe82 Neuer User
    Perfekt. Vielen vielen Dank. VBA Code erweitern *:)*
    Kann man das vielleicht auch umgehen, dass ich für jede Eingabezelle die Entertaste drücken muss?
     
  7. Exl121150 Erfahrener User
    Hallo,

    zu was soll das (wirklich) gut sein?
    Ich habe dir in der beiliegenden Excel-Datei diesen Wunsch erfüllt. Sobald im grünen Eingabebereich eine oder mehrere Zellen geändert werden, werden dort die 32 Zellen durchlaufen und falls Inhalte vorhanden sind, die entsprechenden Abkürzungen in die Spalten H und I eingestellt. Dieser Vorgang benötigt trotz einiger Optimierungen im Code natürlich entsprechend länger - insbesondere fällt dieser Umstand dann auf, wenn sich nur 1 einziger Wert im grünen Bereich geändert hat.
    Code:
    Option Explicit
    
    Dim AllLText() As String, AllKText() As String, AllAText() As String
    Dim ct As Long, i As Long
    Dim Suchspalte As Range, Ergebnis As Range
    Dim KText As String, AText As String
    Dim rngEingabe As Range, rngZelle As Range
    
    Private Sub Worksheet_Change(ByVal Target As Range)
    
    '  If Target.CountLarge <> 1 Then Exit Sub
      
       'Überprüfen, ob Target im Eingabebereich E15:E46 liegt:
       Set rngEingabe = Me.Range("E15:E46")
       If Not Intersect(Target, rngEingabe) Is Nothing Then
      
          Set Suchspalte = Me.ListObjects("tbVerzeichnis").ListColumns("Langbezeichnung").DataBodyRange
        
          For Each rngZelle In rngEingabe.Cells
          
             'Es erfolgt ein Eintrag in Langbezeichnung
             AllLText = Split(rngZelle.Value, " ")
            
             'Zählen der Wörter/Blanks in der Target-Zelle:
             ct = UBound(AllLText)
            
             If rngZelle.Value <> "" Then 'Es ist ein Wert eingetragen
            
                ReDim AllKText(ct) As String
                ReDim AllAText(ct) As String
        
                For i = 0 To ct 'Wiederhole für jeden Langeintrag in der Target-Zelle
                  
                   'Langtext finden
                   Set Ergebnis = Suchspalte.Find(What:=AllLText(i), _
                      LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                      MatchCase:=False, SearchFormat:=False)
                  
                   If Ergebnis Is Nothing Then
                      'Keine Langbezeichnung gefunden
                      AllKText(i) = AllLText(i)
                      AllAText(i) = ""
                   Else
                      'Abkürzung für Langbezeichnung ermitteln
                      AllKText(i) = Ergebnis.Offset(0, 1).Value
                      AllAText(i) = Ergebnis.Offset(0, 2).Value
                   End If
                  
                Next i
              
                KText = Join(AllKText, " ")
                AText = Join(AllAText, " ")
             Else
                KText = "": AText = ""
             End If
             'ActiveSheet.Unprotect ""
             rngZelle.Offset(0, 3).Value = KText
             rngZelle.Offset(0, 4).Value = AText
             'ActiveSheet.Protect ""
            
          Next rngZelle
        
       End If
    
    End Sub
    

    Falls du eine aktuelle Excel-Version (= Excel365) besitzt, habe ich dir in einem zweiten Arbeitsblatt (=Abkürzungsliste (XL365)) eine VBA-freie Lösung eingefügt. Diese verwendet im Prinzip 2 leicht veränderte Formeln und zwar
    in Zelle H15: =WENNFEHLER(TEXTVERKETTEN(" ";WAHR; SVERWEIS(TEXTTEILEN($E15;" "); tbVerzeichnis3;2;0));"")
    in Zelle I15: =WENNFEHLER(TEXTVERKETTEN(" ";WAHR; SVERWEIS(TEXTTEILEN($E15;" "); tbVerzeichnis3;3;0));"")
    Beide Formeln habe ich hinunterkopiert bis zu den Zellen H46 und I46.
     
    Exl121150, 12. Januar 2023
    #7
    1 Person gefällt das.
  8. BePe82 Neuer User

    VBA Code erweitern

    Vielen Dank für die schnelle Hilfe.
    Ich arbeite viel mit SAP, dort bin ich auf 40 Zeichen begrenzt.
    Also muss ich regelmäßig Texte abkürzen.
    Das erleichtert mir jetzt alles sehr.
     
Thema:

VBA Code erweitern

Die Seite wird geladen...
  1. VBA Code erweitern - Similar Threads - VBA Code erweitern

  2. VBA-Code Arbeitsblatt wechseln

    in Microsoft Excel Hilfe
    VBA-Code Arbeitsblatt wechseln: Hallo zusammen, ich habe mal wieder eine Frage. Aktuell beschäftige ich mich mit VBA-Codes. Beim öffnen meiner Arbeitsmappe erscheint folgender Hinweis: Private Sub Workbook_Open() 'Titel Hinweis...
  3. VBA Code nicht vollständig ausgeführt

    in Microsoft Excel Hilfe
    VBA Code nicht vollständig ausgeführt: Hallo Zusammen Ich habe einen Code erstellt der eine Liste in Excel importiert und dann alle Zeilen löscht, welche in der Spalte C entweder "Ersatz" oder "Unfall" enthalten. Wenn ich den Code...
  4. 2x Worksheet_Change(ByVal Target As Range)

    in Microsoft Excel Hilfe
    2x Worksheet_Change(ByVal Target As Range): Hallo zusammen, ich bin VBA-Anfänger und habe die ersten Codes erstellt. Nun möchte ich 2 von Ihnen, welche einzeln funktionieren, zusammenfügen, so dass beide entsprechend durchgeführt werden....
  5. VBA Code Funktioniert nicht

    in Microsoft Excel Hilfe
    VBA Code Funktioniert nicht: Hallo Leute habe ein Code von einem Lieben User bekommen. Obwohl es beim ersten mal funktioniert hat geht es nicht mehr. Da ich den User nicht erreichen kann (er hat wahrscheinlich viel zu tun :-)...
  6. (Präfix wäre MS 365) VBA-Code für leere Zellen

    in Microsoft Excel Hilfe
    (Präfix wäre MS 365) VBA-Code für leere Zellen: Hallo zusammen, ich bräuchte wieder einmal eure geschätzte Hilfe, und zwar suche ich nach einem VBA-Code, der in einer bestimmten Zelle, z.B. A1, einen Text anzeigt, z. B. "Datum eintragen", oder...
  7. MSAccess - Feldinhalt in Formular aus anderer Tabelle befüllen (VBA)

    in Microsoft Access Hilfe
    MSAccess - Feldinhalt in Formular aus anderer Tabelle befüllen (VBA): Hallo und guten Tag allerseits, ich habe ein, für viele von Euch sicherlich einfach zu lösendes Problem. In meiner Tabelle literatur habe ich unter anderem die Felder Magazin, Kennung_Jahrgang,...
  8. Liste mit VBA-Code erweitern/optimieren

    in Microsoft Excel Hilfe
    Liste mit VBA-Code erweitern/optimieren: Hallo, ich habe eine Planungsliste, wo mir letztes Jahr in diesem Forum schon sehr geholfen wurde mit der Programmierung von steve1da. Ich möchte gerne 2 Punkte bei diesem File erweitern: 1....
Schlagworte:
  1. Diese Seite verwendet Cookies, um Inhalte zu personalisieren, diese deiner Erfahrung anzupassen und dich nach der Registrierung angemeldet zu halten.
    Auf dieser Website werden Cookies für die Zugriffsanalyse und Anzeigenmessung verwendet.
    Wenn du dich weiterhin auf dieser Seite aufhältst, akzeptierst du unseren Einsatz von Cookies.
    Information ausblenden