Anzeige
Archiv - Navigation
1620to1624
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
Wörter teils fett formatiert aus Excel in Word
03.05.2018 14:16:22
christoph
Moin moin,
habe eine recht große Tabelle vorliegen, in welcher der Nutzer bestimmte Blöcke makieren kann per Doppelklick.
Sobald alles fertig ist steht ein Button bereit, woraufhin ein Worddokument geöffnet wird und die markierten Bereiche in Textmarken übertragen werden.
Dabei setzen sich die Wörter die in die einzelnen Textmarke übertragen werden teils aus mehreren anderen Wörter zusammen.
Hiervon müssen dann noch einige fett und unterstrichen sein (das erste Wort immer).
Daran scheitere ich gerade bzw. würde es nur über einen unschönen Zwischenspeicher hinbekommen, da die Excel ausgangsdaten auch NICHT verändert werden sollen.
Sehr verkürzter Code:
strMatr = Range("A" & intNummer)
strBaugr = Range("B" & intNummer)
wdRng.Text = strMatr & strBaugr

Der Part (variabler Länge und gelegentlich mehr wie ein Wort) in strMatr soll fett und unterstrichen übertragen werden
Danke schonmal für die Hilfe

16
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
eigentl. reichts wenn der string fett ist
03.05.2018 16:39:43
christoph
wie die überschrift schon sagt:
wie kriege ich den Inhalt eines strings fett, der sich aus mehreren Zellen zusammengestezt hat?
wdRng..Font.Bold = True ..owT
03.05.2018 16:43:16
Peter(silie)

Danke aber....
03.05.2018 17:15:20
christoph
Vielen Dank Peter(silie).
wäre es nun noch möglich nur einen Teil fettzumachen?
Kriege es auch alternativ hin aber verursacht n batzen vorbereitungsarbeit,
und man will ja auch weiterkommen ;)
strBaugr = Range("B" & intNummer)
wdRng.Text = strMatr & strBaugr
wdRng.Font.Bold = True

Hab schon versucht den zweiten Teil (strBaugr) im nachgang einzufügen wurde aber auch mit fett gemacht.
AW: Danke aber....
03.05.2018 17:41:49
Peter(silie)
Hallo,
so z.B.:
    With rng.Text
.Characters(1).Font.Bold = True
End With

Anzeige
:) :(
03.05.2018 18:02:24
christoph
Danke dir.
Bin zu durch gerade.
Hatte es vorhin schon fast (glaube ich zumindest) aber bin dann verzweifel und andere Wege eingeschlagen.
Klappt jetzt zumindest einigermaßen,
mache jetzt schluss für heute.
melde mich morgen wenn ich verzweifel oder es geschafft habe ;)
Danke dir
:(
04.05.2018 07:01:42
christoph
Ich kapiere es nicht!!
soweit ich das sehr ist .characters(start, länge) aufgebaut.
setze ich nun ein
.characters(1, 5) oder gar .characters81, Len(strMatr)) kommt der Fehler:
Laufzeitfehler '450: Falsche Anzahl an Argumenten oder ungültige Zuweisung zu einer Eigenschaft
Wenn ich nur .characters(1) oder (7) oder (Len(strMatr)) einsetze markiert er die Stelle des Buchstabens.
ALso Problem gerade.
Er markiert Bereiche aber leider nur immer einen Buchstaben nicht einen Textabschnitt, da ich es nicht schaffe Start und Länge zu definieren
Anzeige
wdRng.characters <> Range.characters?!
04.05.2018 07:17:13
christoph
Habe gerade noch bisschen weiter herumprobiert.
Wenn ich auf irgendeine Zelle zugreife
Range("H20").Characters(1, Len(strMatr)).Font.Bold = True
macht er genau was er soll
bei
wdRng.Characters(1, 3).Font.Bold = True
kommt der oben genannte Laufzeitfehler
mit For..Next umgangen aber unschön/rechenintensiv
04.05.2018 07:31:58
christoph
For byLaenge = 1 To Len(strMatr)
wdRng.Characters(byLaenge).Font.Bold = True
Next
Aber da meine VBA Kenntnisse eh nicht die besten sind und das Programm schon bei einer kleinen Datenmenge n bisschen braucht, wüsste ich gerne wie ich das besser hinbekomme
Geht nicht anders...
04.05.2018 08:20:23
Peter(silie)
und rechenintensiv ist das null.
Öffne im Word VBA Editor den Objektkatalog[F2] und Suche nach Characters.
Dort findest du dann dass:
Userbild
Was dir verrät, dass das Word Objekt Characters nur einen Parameter
akzeptiert, nämlich Index.
Anzeige
blöd aber vielen dank. Zeitsteigerung 2 auf 9
04.05.2018 08:39:31
christoph
Danke für die Erklärung,
auch wenn ich selbst nicht daraus lesen würde, dass ich nur einen Parameter nutzen kann (oder doch?! wenn dort kein Index as long stehen würde könnte ich mehr übergeben?)
nun habe ich es zumindest mal gesehen und verstehe es nächstes mal vielleicht :)
zur rechenintensivität:
nur das unterstreichen erhöht meine Makrodurchlaufzeit von ca. 2sekunden 08:33:53 - 08:33:55
auf ca.9sekunden 08:33:26 - 08:33:35 und dabei habe ich nur ca. 1/4 der Daten verwendet und möchte das Makro gerne noch weiter ausbauen.
AW: blöd aber vielen dank. Zeitsteigerung 2 auf 9
04.05.2018 09:11:08
Peter(silie)
Hallo,
das liegt dann aber generell daran, welche Funktionen du wie verwendest.
Du verwendest evtl. falsche oder zuviele Objekte.
Funktionen die langsam sind.
Schleifen wo es keine braucht, etc.
2 Sekunden sind schon relativ lange.
Guter Code braucht oft nicht länger als 200ms also 0,2 Sekunden.
Du machst evtl zu viele Dinge auf einmal.
Beachte, dass es sehr lange dauert um z.B. eine Word Datei aus Excel VBA heraus zu öffnen.
Wenn durch öffnen von Dateien die Laufzeit hoch geht.. naja dann ist das halt so.
Die Bildschirmaktualisierung ignorieren wir einfach mal... die braucht nun mal ihre Zeit.
Zu Excel:
  • Arrays statt Range

  • Kein Select

  • Kein ActiveSheet etc.

  • Sortiere Daten falls nötig um Laufzeit zu verbessern

  • Sortiere mit eigenem Algorithmus und nicht mit On-Board mitteln

  • Verwende kein Range.Find, das ist einfach schrott.

  • Alternative zu find:
    Application.Match, Lineare Suche durch Array,
    Bei sortierten Daten: BinarySearch, InterpolationSearch (nur bei Zahlen)

  • Anzeige
    Beispiel Code zu Optimierung:
    04.05.2018 09:32:16
    Peter(silie)
    Findet eine ID in einem Array (Diesen Code verwende ich in einem Projekt)
    Die IDs sind der Größe nach sortiert.
    Laufzeit bei +4000 IDs = 0,0045 Sekunden
    Laufzeit von Application.Match = 0,0147 Sekunden
    Durch die Interpolation Suche spare ich mir also bei jeder ID die gesucht wird 10ms.
            'Get the last row and then try to find the ID
    i = .Cells(.Rows.Count, DBxy.ReportNumber).End(xlUp).Row
    src = OneDimensionRange(.Range(.Cells(2, DBxy.ReportNumber), _
    .Cells(i, DBxy.ReportNumber)))
    i = InterpolationSearch(CLng(ID), src, LBound(src), UBound(src)) + 2
    
    InterpolationSort und OneDimensionRange:
    Private Function OneDimensionRange(ByRef rng As Range) As Variant
    OneDimensionRange = Split(Join(Application.Transpose(rng.value2), ";"), ";")
    End Function
    Private Function InterpolationSearch(ByVal key As Long, _
    ByRef source As Variant, _
    ByVal low As Long, _
    ByVal high As Long) As Long
    Dim ref As Long
    While (CLng(source(high))  CLng(source(low))) _
    And (key >= CLng(source(low))) _
    And (key 

    Anzeige
    Danke!! / Code-Anregung Zeit&Lust?!
    04.05.2018 14:28:56
    christoph
    Echt richtig gut, wie du mir hilfst!!
    Wie schon vorher gesagt, bin ich noch sehr am Anfang und suche mir meistens die Sachen zurecht die ich brauche, damit es zumindest von der Funktion her läuft.
    Das ergibt aber meist keinen recht guten Code, da ich nicht wirklich in der Materie stecke und von Arrays zum Beispiel noch nichts gehört habe :(
    Arrays wären auf jedenfall ein Punkt den ich die Tage mal angehen werde um den Code zu verbessern (nachdem ich mich etwas eingelesen habe).
    Ich werde hier mal beschreiben, was mein Code machen soll und im im nächsten Post anhängen.
    Würde mich mega freuen, wenn du mir ein kurzes Feedback gibst, an welchen Stellen des Codes du Verbesserungspotential siehst. Anmerkung/Vorschläge würden reichen.
    Bin übers Wochenende nicht erreichbar (heute nur bis 17) und werde erst Montag wieder reinschauen.
    Was soll der Code machen:
    Ich habe eine Excel Tabelle in der es 3 verschiedene Materialgruppen gibt (Spalte A)
    Jede Materialgruppe ist in unterschiedlich viele Untergruppen aufgeteilt (Spalte B)
    Jeder Untergruppe sind diverse mögliche Lieferanten zugeordnet (bis zu 30) (Spalte C)
    weitere Spalten enthalten wer dafür zuständig ist und wo gefertigt wird aber das spielt zur Zeit noch keine Rolle
    Spalte A(bereits hinterlegt) und B(noch nicht aber folgt) enthalten die Materialgruppe in Deutscher/Englischer/Spanischer/Russischer Bezeichnung.
    Der Nutzer hat ToggleButtons mit denen er VOR Programmausführung die Sprachreihenfolge und auswahl anwählen kann.
    Heißt der Nutzer kann entscheiden ob am Ende auf dem Word dokument die Materialgruppe, sowie Untergruppe erst auf spanisch und dann englisch vorliegt
    oder ob 1.deutsch, 2.russisch und 3.englisch steht etc.....
    Auch werden vorgefertigte Texte als Einleitung in der ausgewählten Reihenfolge eingefügt.
    Per Doppelklick event kann der Nutzer weiterhin verschiedene Untergruppen an/abwählen.
    Die angewählten Untergruppen werden farblich hinterlegt und färben automatisch auch die Lieferanten die dieser Untergruppe zugeordnet sind.
    Bei den Lieferanten kann der Nutzer anschließend einzelne Lieferanten per Doppelklickevent wieder abwählen.
    Am Ende befindet sich ein Ausführbutton, der die Daten aus der Tabelle herrausliest und Textmarken in einem Wortdokument zu ordnet.
    Zusätzlich wird der Projektname den man vorher eingetragen hat und das aktuelle Datum in den Kopf des Worddokument übertragen.
    Die Tabelle umfasst bis dato ~500Zeilen
    Anzeige
    Mein Code
    04.05.2018 14:31:02
    christoph
    
    Private Sub CommandButton1_Click()
    Dim AppWD As Object, docTest As Object, c As Object
    Dim wdRng As Object, wdDoc As Object
    Dim Textmarke  As String, Dateiname As String, strLief As String, strMatr As String, strBaugr  _
    As String
    Dim Textm_nr As Integer, intNummer As Integer, intNummer2 As Integer
    Dim bySprache As Byte, byLaenge As Byte
    Textm_nr = 1
    Set AppWD = CreateObject("Word.Application") 'Word als Object starten
    AppWD.Visible = True 'die Datei anzeigen und nicht im Hintergrund versteckt öffnen
    Set wdDoc = AppWD.Documents.Open("Mein COde\test.docx")  'die gewünschte Datei öffnen
    Set wksTabelle = Worksheets("test") ' festlegen aus welchem Tabellen Blatt Daten kommen
    Set wdRng = wdDoc.Bookmarks("Datum").Range
    wdRng.Text = Date
    Set wdRng = wdDoc.Bookmarks("Projekt").Range
    wdRng.Text = Range("E1")
    For intNummer = 1 To 4
    If Range("A" & intNummer) = "" Then
    Else
    Set wdRng = wdDoc.Bookmarks("Textmarke" & Textm_nr).Range ' sagt welche Textmarke  _
    angesprochen wird
    Select Case Range("A" & intNummer)
    Case "Deutsch"
    wdRng.Text = Range("H6") ' was in die angesprochene Textmarke geschrieben wird
    Case "Englisch"
    wdRng.Text = Range("H7")
    Case "Spanisch"
    wdRng.Text = Range("H8")
    Case "Russisch"
    wdRng.Text = Range("H9")
    End Select
    wdDoc.Bookmarks.Add "Textmarke" & Textm_nr, wdRng ' Setzt die angesprochene Textmarke zurü _
    ck, andernfalls ist diese gelöscht
    Textm_nr = Textm_nr + 1
    End If
    Next
    Textm_nr = 5
    For intNummer = 16 To ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
    intNummer2 = intNummer
    Do While Range("B" & intNummer2).Borders(xlEdgeBottom).Weight  xlMedium
    intNummer2 = intNummer2 + 1
    Loop
    If Range("B" & intNummer).Interior.ColorIndex = 4 Then
    Set wdRng = wdDoc.Bookmarks("Textmarke" & Textm_nr).Range ' sagt welche Textmarke  _
    angesprochen wird
    strMatr = ""
    For bySprache = 1 To 4
    Select Case Range("A" & bySprache)
    Case ""
    Case "Deutsch"
    If strMatr = "" Then
    strMatr = Range("A" & intNummer)
    Else: strMatr = strMatr & "/" & Range("A" & intNummer) ' was in die angesprochene  _
    Textmarke geschrieben wird
    End If
    Case "Englisch"
    If strMatr = "" Then
    strMatr = Range("A" & intNummer + 1)
    Else: strMatr = strMatr & "/" & Range("A" & intNummer + 1)
    End If
    Case "Spanisch"
    If strMatr = "" Then
    strMatr = Range("A" & intNummer + 2)
    Else: strMatr = strMatr & "/" & Range("A" & intNummer + 2)
    End If
    Case "Russisch"
    If strMatr = "" Then
    strMatr = Range("A" & intNummer + 3)
    Else: strMatr = strMatr & "/" & Range("A" & intNummer + 3)
    End If
    End Select
    Next
    strMatr = strMatr & ":" & vbCr ' vbCr ist die Entertaste
    strBaugr = Range("B" & intNummer)
    wdRng.Text = strMatr & vbCr & strBaugr
    For byLaenge = 1 To Len(strMatr)            ' um die Materialart fett und  _
    unterstrichen darzustellen
    wdRng.Characters(byLaenge).Font.Bold = True
    wdRng.Characters(byLaenge).Font.Underline = True
    Next
    wdDoc.Bookmarks.Add "Textmarke" & Textm_nr, wdRng ' Setzt die angesprochene  _
    Textmarke zurück, andernfalls ist diese gelöscht
    Textm_nr = Textm_nr + 1
    strLief = ""
    Do While intNummer 

    Anzeige
    AW: Mein Code
    04.05.2018 16:23:05
    Peter(silie)
    Hallo,
    hier eine Mappe mit Code: https://www.herber.de/bbs/user/121442.xlsm
    Verwendet Types und Const um Daten zu "speichern".
    Stellt einen Teil deines Codes dar.
    Unterteilt deinen Code in Unterprozeduren um ihn
    sicherer zu machen.
    Dadurch hat man mehr möglichkeiten, übersichtlich, Fehler und Probleme zu behandeln.
    Wenn du was nicht verstehst oder generell fragen hast, kannst du die natürlich gerne stellen.
    Hier nur Code:
    Option Explicit
    'typ der generelle Daten speichert
    Private Type GLOBAL_BOOKMARK
    DateTime As String
    ProjectName As String
    End Type
    'typ der deutsch spezifische daten speichert
    Private Type GERMAN_BOOKMARK
    General As GLOBAL_BOOKMARK
    Language As String
    SpecificWords() As String
    End Type
    'typ der englisch spezifische daten speichert
    Private Type ENGLISH_BOOKMARK
    General As GLOBAL_BOOKMARK
    Language As String
    SpecificWords() As String
    End Type
    'typ der spanisch spezifische daten speichert
    Private Type SPANISH_BOOKMARK
    General As GLOBAL_BOOKMARK
    Language As String
    SpecificWords() As String
    End Type
    'typ der russisch spezifische daten speichert
    Private Type RUSSIAN_BOOKMARK
    General As GLOBAL_BOOKMARK
    Language As String
    SpecificWords() As String
    End Type
    'type der alle sprach textmarken vereinigt
    Private Type BOOKMARK_PACKAGE
    GER     As GERMAN_BOOKMARK      'deutsche daten
    EN      As ENGLISH_BOOKMARK     'englische daten
    ESP     As SPANISH_BOOKMARK     'spanische daten
    RUS     As RUSSIAN_BOOKMARK     'russische daten
    End Type
    'textmarken namen
    Private Const BM_DATUM      As String = "Datum"
    Private Const BM_PRJKT      As String = "Projekt"
    Private Const BM_VAR        As String = "Textmarke"
    'member variablen
    Private word_application    As Object
    Private word_document       As Object
    Private bmp                 As BOOKMARK_PACKAGE
    Private Function GetApplication() As Object
    Dim wApp As Object
    'falls word nicht erstellt werden kann dann raus
    On Error GoTo FailedToCreateInstance
    'versuche word zu erstellen
    Set wApp = CreateObject("Word.Application")
    'mache sichtbar
    wApp.Visible = True
    'gebe objekt weiter
    Set GetApplication = wApp
    FailedToCreateInstance:
    'falls fehler aufgetreten
    If Err.Number  0 Then
    'setze auf nichts
    Set GetApplication = Nothing
    'lösche fehler
    Err.Clear
    End If
    End Function
    Private Function GetDocument() As Object
    Dim wDoc As Object
    'Dateipfad
    Const WD_DOCUMENT_PATH As String = "Mein Code\test.docx"
    'falls document nicht geöffnet werden kann dann raus
    On Error GoTo FailedToGetDocument
    'versuche datei zu öffnen
    Set wDoc = word_application.Documents.Open(WD_DOCUMENT_PATH)
    'gebe objekt weiter
    Set GetDocument = wDoc
    FailedToGetDocument:
    'falls fehler aufgetreten
    If Err.Number  0 Then
    'setze auf nichts
    Set GetDocument = Nothing
    'lösche fehler
    Err.Clear
    End If
    End Function
    Private Sub GetBookmarks()
    Dim shSource    As Worksheet
    Dim GLBBM       As GLOBAL_BOOKMARK
    Set shSource = ThisWorkbook.Sheets("test")
    With shSource
    'standard daten einfügen
    GLBBM.DateTime = CStr(Date)
    GLBBM.ProjectName = .Cells(1, 5).Value
    'standarddaten an jeweiliges sprachpacket geben
    bmp.GER.General = GLBBM
    bmp.EN.General = GLBBM
    bmp.ESP.General = GLBBM
    bmp.RUS.General = GLBBM
    'textmarken text für das jeweilige sprachpacket
    bmp.GER.Language = .Range("H6").Value
    bmp.EN.Language = .Range("H7").Value
    bmp.ESP.Language = .Range("H8").Value
    bmp.RUS.Language = .Range("H9").Value
    End With
    End Sub
    Private Sub SetDefaultBookmarks()
    Dim shSource    As Worksheet
    Dim wdRng       As Object
    Dim tmp         As Variant
    Dim idx         As Long
    Dim i           As Long
    Set shSource = ThisWorkbook.Sheets("test")
    word_document.Bookmarks(BM_DATUM).Range.Text = bmp.EN.General.DateTime
    word_document.Bookmarks(BM_PRJKT).Range.Text = bmp.EN.General.ProjectName
    idx = 1
    For i = 1 To 4
    'definiere marke
    Set wdRng = word_document.Bookmarks(BM_VAR & idx).Range
    'LCase um Groß-/Kleinschreibung zu ignorieren
    Select Case LCase(shSource.Cells(i, 1).Value)
    Case "deutsch"
    tmp = bmp.GER.Language
    Case "englisch"
    tmp = bmp.EN.Language
    Case "spanisch"
    tmp = bmp.ESP.Language
    Case "russisch"
    tmp = bmp.RUS.Language
    Case Else: tmp = vbNullString
    End Select
    If Not tmp = vbNullString Then
    'füge text ein
    wdRng.Text = tmp
    'setze die textmarke erneut drauf
    word_document.Bookmarks.Add BM_VAR & idx, wdRng
    'resete tmp
    tmp = vbNullString
    'erhöhe index
    idx = idx + 1
    End If
    Next i
    End Sub
    Public Sub test()
    'öffne word
    Set word_application = GetApplication
    'beende falls fehlgeschlagen
    If word_application Is Nothing Then Exit Sub
    'öffne word dokument
    Set word_document = GetDocument
    'schließe Word App falls fehlgeschlagen
    'beende bei fehlschag
    If word_document Is Nothing Then
    word_application.Quit
    Exit Sub
    End If
    'hole dir standard textmarken daten
    GetBookmarks
    'setze standard textmarken daten ein
    SetDefaultBookmarks
    End Sub
    

    Anzeige
    o.O da hab ich was zu tun am Montag
    04.05.2018 16:45:28
    christoph
    ok, ich kapiere gerade nichts :D bzw. nicht viel und schon traurig wie mein Code komplett verschwindet :D
    setze mich damit anfang nächster Woche auseinander oder wenns regnet am Wochenende ;)
    Dir wünsche ich erstmal ein schönes Wochenende und nochmals vielen Dank

    301 Forumthreads zu ähnlichen Themen

    Anzeige
    Anzeige
    Anzeige

    Links zu Excel-Dialogen

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige