Office: 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?


.
Viele Grüße
BePe

 

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

 

Hallo,

stelle doch bitte eine Beispieldatei ein, das erhöht die Change auf Lösungsvorschläge ganz erheblich.

 

Stimmt :-)
Hier die Datei.
Danke das du dir das mal anschaust.

 

Hallo,

habe dir ein Suchmakro eingefügt. Deine Suchtabelle habe ich in eine strukturierte Tabelle namens "tbVerzeichnis" umgewandelt.

 

Perfekt. Vielen vielen Dank.
Kann man das vielleicht auch umgehen, dass ich für jede Eingabezelle die Entertaste drücken muss?

 

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.

 

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.