Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1612to1616
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

per VBA 2 Buchstaben jedes Wortes.

per VBA 2 Buchstaben jedes Wortes.
08.03.2018 10:06:41
Jürgen
Hallo VBA Profis
Leider kann ich auch nach langem Suchen keine Lösung finden, welche ich mir zurecht Basteln könnte:
Zu meinem Problem:
Ich würde gerne ersten 2 Buchstaben von jedem Wort einer Zelle finden, mit punkt versehen und verbinden.
Momentan habe ich mir aus Planlosigkeit wie folgt beholfen.

strTabelle = Zelle
Zelle = Left(Range("d1"), 18) & ". "

Diese Zeichen folge ist allerdings zu lange, aber notwendig um den Zusammenhang zu verstehen.
da es sich um 2 - 4 Worte handeln kann wären 2 Buchtaben mit Punkt pro Wort ausreichend.

Soll heißen (als Bsp):
Aktuell:
aus "Desoxyribonukleinsäure Kette Doppelhelix Aminosäure"
wird "Desoxyribonukleins."
Neue Lösung:
aus "Desoxyribonukleinsäure Kette Doppelhelix Aminosäure"
wird "De. Ke. Do. Am."  

Ich hoffe ich habe mich einigermaßen verständlich ausgedrückt.
Vielen Dank schon mal und
Mit Beste Grüße
Jürgen

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: per VBA 2 Buchstaben jedes Wortes.
08.03.2018 10:08:00
Jürgen
p.S. toll wäre wenn ich im Code die Zeichenlänge jedes Wortes definieren könnte
AW: per VBA 2 Buchstaben jedes Wortes.
08.03.2018 10:23:47
Hajo_Zi
deine Ergänzung ist6 mir nicht klar.
Option Explicit
Sub Punkt()
Dim StWert As String
Dim StWert2 As String
Dim Loi As Long
StWert = ActiveCell
ActiveCell.ClearContents
For Loi = 1 To Len(StWert)
If InStr(StWert, " ") > 0 Then
StWert2 = Left(StWert, InStr(StWert, " "))
StWert = Mid(StWert, InStr(StWert, " ") + 1)
Else
StWert2 = StWert
End If
ActiveCell = ActiveCell & Left(StWert2, 2) & ". "
If StWert = StWert2 Then
Exit For
End If
Next Loi
ActiveCell = Trim(ActiveCell)
End Sub

Beiträge von Werner, Luc, robert, J.O.Maximo und folgende lese ich nicht.
Anzeige
AW:mit Split
08.03.2018 10:26:38
hary
Moin
Hier mit Split
Dim a As Variant
Dim i As Long, Anzahl As Long
Dim strText As String
With Cells(1, 1) '--Text steht in A1
Anzahl = Application.InputBox("Bitte Zeichenanzahl eingeben", Type:=1)
If Anzahl > 0 Then
a = Split(.Value, " ")
For i = LBound(a) To UBound(a)
strText = strText & Left(a(i), Anzahl) & ". "
Next
MsgBox strText
End If
End With

gruss hary
AW: AW:mit Split
09.03.2018 12:59:23
Jürgen
Hallo Harry
Vielen Dank für deinen Code, dieser hat mir schon geholfen!
Allerdings habe ich immernoch einen Fehler im code, den ich nicht ausmachen kann!
ICh habe in D1 6 Worte mit jeweils über 5 Buchstaben stehen.
Wenn ich den Code nun starte, und die Anzahl 5 eingebe, läuft der Code einwandfrei ab und er sagt mir zum Ende, das es zuviele Buchstaben sind und der Code started den Code über Call erneut.
Jetzt werde ich wieder gefragt wie viele Zeichen ich nutzen möchte: Wenn ich nun auf Abbrechen gehe, kommt die Fehlermeldung!
Wo liegt der Fehler? Ich fürchte auch das meine ganzen "End If" nicht so richtig sind.
Beste Grüße Jürgen
HIer der Code:
Sub Tabellenblatt_benennen()
'MsgBox Worksheet.Name
Dim blnFalsch As Boolean
Dim strTabelle As String
Dim arrFalsch()
Dim bytFalsch As Byte
Dim wksTab As Worksheet
arrFalsch = Array("*", "[", "]", "/", "\", "?", ":")
Dim Ret_type As Integer
Dim strMsg As String
Dim strTitle As String
Dim a As Variant
'Dim anzahl1 As Variant
Dim i As Long, anzahl As Long
Dim strText As String
Dim strText1 As String
Call Passwort_aus
With Cells(1, 4) '--Text steht in d1
anzahl1 = Application.InputBox("Wie viele Zeichen pro Wort," & vbNewLine & "sollen für den  _
Namen benutzt werden?" & vbNewLine & "" & vbNewLine & "Geben Sie die Zahl ein!" & vbNewLine & " ", vbOKCancel)
anzahl = anzahl1
If anzahl  0 Then
a = Split(.Value, " ")
For i = LBound(a) To UBound(a)
strText = strText & Left(a(i), anzahl) & ". " 'Zahl entspricht der Zeichenanzahl
Next
strText1 = strText & Left(Range("d2"), 6) & "."
End If
Ret_type = MsgBox(strText1, 3)
Select Case Ret_type
Case 2
Exit Sub
Case 7
'MsgBox "nochmal"
Call Tabellenblatt_benennen
Exit Sub
Case 6
strTabelle = Zelle
Zelle = strText1
If Range("d1") = "" Then
MsgBox "Der Name der Einrichtung fehlt"
Exit Sub
Else
' Zeichen nicht mehr als 31
If Len(Zelle) > 31 Then
MsgBox "Zu viele Zeichen gewählt, bitte geben Sie weniger Zeichen ein!"
Call Tabellenblatt_benennen
End If
For Each wksTab In Sheets
If wksTab.Name = Zelle Then
blnFalsch = True
Exit For
End If
Next wksTab
If blnFalsch Then
MsgBox "Name bereits vorhanden"
Call Tabellenblatt_benennen
Else
' unerlaubte Zeichen prüfen
For bytFalsch = 0 To 6
If InStr(Zelle, arrFalsch(bytFalsch)) > 0 Then
MsgBox "In Einrichtung oder Ort sind " & vbNewLine & "" &  _
vbNewLine & "unerlaubte Zeichen enthalten * [ ] / \ ? :"
blnFalsch = True
Exit For
End If
Next bytFalsch
If blnFalsch = True Then
ActiveSheet.Name = strTabelle
'   MsgBox "Zu viele Zeichen gewählt, bitte geben Sie weniger  _
Zeichen ein!"
'   Call Tabellenblatt_benennen
End If
ActiveSheet.Name = Zelle
MsgBox "Tabellennamen eingetragen"
End If
End If
End Select
End If
End With
Call Passwort_an
End Sub

Anzeige
AW: AW:mit Split
09.03.2018 13:33:55
Jürgen
Hallo Harry
Vielen Dank für deinen Code, dieser hat mir schon geholfen!
Allerdings habe ich immernoch einen Fehler im code, den ich nicht ausmachen kann!
ICh habe in D1 6 Worte mit jeweils über 5 Buchstaben stehen.
Wenn ich den Code nun starte, und die Anzahl 5 eingebe, läuft der Code einwandfrei ab und er sagt mir zum Ende, das es zuviele Buchstaben sind und der Code started den Code über Call erneut.
Jetzt werde ich wieder gefragt wie viele Zeichen ich nutzen möchte: Wenn ich nun auf Abbrechen gehe, kommt die Fehlermeldung!
Wo liegt der Fehler? Ich fürchte auch das meine ganzen "End If" nicht so richtig sind.
Beste Grüße Jürgen
HIer der Code:
Sub Tabellenblatt_benennen()
'MsgBox Worksheet.Name
Dim blnFalsch As Boolean
Dim strTabelle As String
Dim arrFalsch()
Dim bytFalsch As Byte
Dim wksTab As Worksheet
arrFalsch = Array("*", "[", "]", "/", "\", "?", ":")
Dim Ret_type As Integer
Dim strMsg As String
Dim strTitle As String
Dim a As Variant
'Dim anzahl1 As Variant
Dim i As Long, anzahl As Long
Dim strText As String
Dim strText1 As String
Call Passwort_aus
With Cells(1, 4) '--Text steht in d1
anzahl1 = Application.InputBox("Wie viele Zeichen pro Wort," & vbNewLine & "sollen für den  _
Namen benutzt werden?" & vbNewLine & "" & vbNewLine & "Geben Sie die Zahl ein!" & vbNewLine & " ", vbOKCancel)
anzahl = anzahl1
If anzahl  0 Then
a = Split(.Value, " ")
For i = LBound(a) To UBound(a)
strText = strText & Left(a(i), anzahl) & ". " 'Zahl entspricht der Zeichenanzahl
Next
strText1 = strText & Left(Range("d2"), 6) & "."
End If
Ret_type = MsgBox(strText1, 3)
Select Case Ret_type
Case 2
Exit Sub
Case 7
'MsgBox "nochmal"
Call Tabellenblatt_benennen
Exit Sub
Case 6
strTabelle = Zelle
Zelle = strText1
If Range("d1") = "" Then
MsgBox "Der Name der Einrichtung fehlt"
Exit Sub
Else
' Zeichen nicht mehr als 31
If Len(Zelle) > 31 Then
MsgBox "Zu viele Zeichen gewählt, bitte geben Sie weniger Zeichen ein!"
Call Tabellenblatt_benennen
End If
For Each wksTab In Sheets
If wksTab.Name = Zelle Then
blnFalsch = True
Exit For
End If
Next wksTab
If blnFalsch Then
MsgBox "Name bereits vorhanden"
Call Tabellenblatt_benennen
Else
' unerlaubte Zeichen prüfen
For bytFalsch = 0 To 6
If InStr(Zelle, arrFalsch(bytFalsch)) > 0 Then
MsgBox "In Einrichtung oder Ort sind " & vbNewLine & "" &  _
vbNewLine & "unerlaubte Zeichen enthalten * [ ] / \ ? :"
blnFalsch = True
Exit For
End If
Next bytFalsch
If blnFalsch = True Then
ActiveSheet.Name = strTabelle
'   MsgBox "Zu viele Zeichen gewählt, bitte geben Sie weniger  _
Zeichen ein!"
'   Call Tabellenblatt_benennen
End If
ActiveSheet.Name = Zelle
MsgBox "Tabellennamen eingetragen"
End If
End If
End Select
End If
End With
Call Passwort_an
End Sub

Anzeige
AW: per VBA 2 Buchstaben jedes Wortes.
08.03.2018 11:27:51
EtoPHG
Hallo Jürgen,
Diesen Code in ein Modul.
Public Function TextCompress(Text As String, _
Optional CompressLength As String = 2, _
Optional InDelimiter As String = " ", _
Optional OutDelimiter As String = ".") As String
Dim lx As Long
Dim tmp
tmp = Split(Text, InDelimiter)
For lx = 0 To UBound(tmp)
tmp(lx) = Left(tmp(lx), CompressLength) & OutDelimiter & InDelimiter
Next lx
TextCompress = Join(tmp, "")
End Function

Aufruf im Code z.B.:
MsgBox TextCompress(Range("A1"))

oder als Formel im Tabellenblatt (Beispiel Varianten)
=TextCompress(A1)
=TextCompress(A2;3)
=TextCompress(A3;2;;"-")
=TextCompress(A4;6;"blabla";"")
Gruess Hansueli
Anzeige
Kleine Korrektur...
08.03.2018 11:45:24
EtoPHG
Hallo,
Meine zweite Codezeile sollte lauten:
                              Optional CompressLength As Long = 2, _

Es funktioniert zwar auch mit As String ist aber unsauber programmiert, da die Länge nur eine Ganzzahl sein kann.
Gruess Hansueli
AW: Kleine Korrektur...
08.03.2018 12:11:51
Jürgen
Ihr seid die Besten!!! Freu!
Nur wie kann ich den Code am beste in folgenden integrieren?
Sub Tabellenblatt_benennen()
'MsgBox Worksheet.Name
Dim blnFalsch As Boolean
Dim strTabelle As String
Dim arrFalsch()
Dim bytFalsch As Byte
Dim wksTab As Worksheet
arrFalsch = Array("*", "[", "]", "/", "\", "?", ":")
Call Passwort_aus
strTabelle = Zelle
Zelle = Left(Range("d1"), 18) & ". " & Left(Range("d2"), 6) & "."
If Range("d1") = "" Then
MsgBox "Der Name der Einrichtung fehlt"
blnFalsch = True
Else
' Zeichen nicht mehr als 31
If Len(Zelle) > 31 Then strTabelle = Left(Zelle, 31)
For Each wksTab In Sheets
If wksTab.Name = Zelle Then
blnFalsch = True
Exit For
End If
Next wksTab
If blnFalsch Then
'MsgBox "Tabelle bereits vorhanden"
Else
' unerlaubte Zeichen prüfen
For bytFalsch = 0 To 6
If InStr(Zelle, arrFalsch(bytFalsch)) > 0 Then
MsgBox "In Einrichtung oder Ort sind " & vbNewLine & "" & vbNewLine & " _
unerlaubte Zeichen enthalten * [ ] / \ ? :"
blnFalsch = True
Exit For
End If
Next bytFalsch
End If
End If
' all Bedingungen für Name erfüllt
If blnFalsch = False Then
'ActiveSheet.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Zelle
'MsgBox "Tabellennamen eingetragen"
End If
Call Passwort_an
End Sub
Mit dem Ergebnis aus D1 und D2 soll das Tabellenblatt umbenannt werden. (D2 könnte ich so belassen da dort ausschließlich ein Wort steht)
Beste Grüße
Anzeige
Keine Ahnung...
08.03.2018 13:18:19
EtoPHG
Jürgen,
denn das verstehe ich nicht:
strTabelle = Zelle
Zelle = Left(Range("d1"), 18) & ". " & Left(Range("d2"), 6) & "."

Was für Strings willst du verkürzen?
Schon mal mit
Zelle = TextCompress(Zelle)
probiert?
Gruess Hansueli
AW: Keine Ahnung...
08.03.2018 13:43:49
Jürgen
Hallo
strTabelle = Zelle
Zelle = Left(Range("d1"), 18) & ". " & Left(Range("d2"), 6) & "."
Hat die ersten 18 Buchtaben aus D1 & ". " und die ersten 6 Buchtaben aus D2 &". " zusammengefügt.
Mitllerweile habe ich es aber geschafft den Code von Harry zu Integrieren.
Vielen Dank für eure Hilfe, ohne wäre ich aufgeschmissen!
So wie ich fertig bin stelle ich den Kompletten Code nochmal ein! Vielleicht kann es jemand brauchen!
Danke
Gruß Jürgen
Anzeige
Das geht schon mit UDFs aus dem Archiv, ...
08.03.2018 19:10:50
Luc:-?
…die vielfältig einsetzbar sind, Jürgen:
{=VJoin(LINKS(VSplit(A17);2);". ")&"."}
Die UDFs VJoin und VSplit wurden bereits vielfach im Archiv verlinkt. Die letzt­publi­zier­ten Versionen 1.4 und 1.1 sind in einer hoch­ge­la­de­nen BspDatei enthalten. VJoin kann in deiner Xl-Version sicher (angepasst!) durch xl-neues TEXTVERKETTEN ersetzt wdn.
Gruß, Luc :-?
Allerdings fktioniert die RECHERCHE hier ...
09.03.2018 00:43:12
Luc:-?
…zZ nicht, Jürgen,
du müsstest also bei Interesse ggf noch mal den DownLoad-Link nachfragen.
Luc :-?

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige