Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1252to1256
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

Neues Posting: Code weiter ergänzen

Neues Posting: Code weiter ergänzen
Pascal
Guten Tag zusammen
Leider antwortete mir ganz weit unten in meinem Posting vom 16.03. niemand mehr, weshalb ich mir erlaube,
hier ein neues Posting zu starten.
Dank dem Forumsbenutzer RAMSI hab ich hier übers Forum einen Supertollen Code erhalten mittels welchem ich
ab einer PPT – Präsentation alle Texte, welche mit einem * gekennzeichnet sind ins Excel importieren kann:
Private Sub CommandButton1_Click()
Dim objPP As Object
Dim objP As Object 'PowerPoint.Presentation
Dim objS As Object 'PowerPoint.Slide
Dim SH As Object
Dim I As Integer, lngCount As Long
Dim Arr As Variant
'Application.ScreenUpdating = False
'PPT = Shell("C:\Program Files\Microsoft Office\OFFICE11\POWERPNT.EXE")
Set objPP = GetObject(, "PowerPoint.Application")
Set objP = objPP.ActivePresentation
For Each objS In objP.Slides 'Schleife über alle Slides
For Each SH In objS.Shapes ''Schleife über alle Shapes in der Slide
Arr = Split(SH.TextFrame.TextRange.Text, Chr(13) & Chr(13)) 'Text aufteilen nach 2  _
Zeilenumbrüchen hintereinander
For I = LBound(Arr) To UBound(Arr)
If Left(Arr(I), 1) = "*" Then 'Aufteilungen überprüfen ob 1tes Zeichen ein *
L = L + 1
Sheets("Tabelle1").Cells(L, 1).Value = Arr(I)
End If
Next
Next
Next
End Sub
Dieser Code funktioniert einwandfrei.
Leider aber schaffe ich es nicht, den Code auf meine weiteren Bedürfnisse anzupassen. Dh. Ich möchte den Code so anpassen,
dass er mir aus der PPT – Präsentation im Hintergrund nur jene Zeilen ausliest, die zwischen * und ** stehen.
D.h. in der Präsentation drin hat es recht viel Fliesstext. Dieser soll durchsucht werden nach * - Symbolen.
Überall wo so ein Sternchen steht, soll der Text bis zum nächsten ** (Doppelsternchen) ins Excel auf die Tabelle1 kopiert werden.
In Excel drin soll allenfalls bestehender Text auf der Tabelle1 nicht überschrieben werden, sondern der neu kopierte Text soll in die nächste
Leere Zeile geschrieben werden.
Zwischen welchen Symbolen der Text genau steht (in meinem Beispielfile zwischen * und **) spielt eigentlich keine Rolle. Wichtig ist nur, dass ich
Start und Ende eines Textes angeben kann.
Wäre supernett, wenn mir jemand bei meinem Vorhaben weiterhelfen könnte.
Im voraus herzlichen Dank !
https://www.herber.de/bbs/user/79443.ppt

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Neues Posting: Code weiter ergänzen
19.03.2012 20:26:47
ransi
Hallo
Wenn du deine Texte so markieren könntest:
*# Guten Tag !
Dies ist ein erster Text, welcher Per Makro in eine (oder auch mehrere)
Zeilen von Excel importiert werden sollen.*
Diese zwei Zeilen hier sollen dagegen nicht importiert werden, da keine
Entsprechende Kennzeichnung (Stern)
*# Dieser Text hier muss aber wieder kopiert und nach Excel übertragen werden
da er mittels einem kleinen Stern vorn dran entsprechend gekennzeichnet ist.*
dann musst du den Code nur minimal ändern:
Option Explicit

Private Sub CommandButton1_Click()
    
    Dim objPP As Object
    Dim objP As Object 'PowerPoint.Presentation
    Dim objS As Object 'PowerPoint.Slide
    Dim SH As Object
    Dim I As Integer, lngCount As Long
    Dim Arr As Variant
    'Application.ScreenUpdating = False
    'PPT = Shell("C:\Program Files\Microsoft Office\OFFICE11\POWERPNT.EXE")
    Set objPP = GetObject(, "PowerPoint.Application")
    Set objP = objPP.ActivePresentation
    '###########
    With Sheets("Tabelle1")
        lngCount = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    '###########
    For Each objS In objP.Slides 'Schleife über alle Slides
        For Each SH In objS.Shapes ''Schleife über alle Shapes in der Slide
            '################
            Arr = Split(SH.TextFrame.TextRange.Text, "*") 'Text aufteilen nach *
            For I = LBound(Arr) To UBound(Arr)
                '###############
                If Left(Arr(I), 1) = "#" Then 'Aufteilungen überprüfen ob 1tes Zeichen ein #
                    lngCount = lngCount + 1
                    Sheets("Tabelle1").Cells(lngCount, 1).Value = Arr(I)
                End If
            Next
        Next
    Next
End Sub


ransi
Anzeige
AW: Neues Posting: Code weiter ergänzen
19.03.2012 20:34:43
Pascal
Hallo Ransi
Vielen vielen vielen herzlichen Dank für Deine Superschnelle und tolle Antwort !
ich werde das gleich mal austesten. Feedback folgt selbstverständlich
AW: Neues Posting: Code weiter ergänzen
19.03.2012 20:52:22
Pascal
Ich nochmals !
Einfach SENSATIONELL dieser Ransi ! Vielen Dank ! Ohne Dich wär ich hier nie weitergekommen.
Nun muss ich den Code versuchen noch etwas auszubauen:
Folgendes möchte ich noch ändern einfügen:
Beim Start des Makros soll ein Dialogfenster erscheinen aus welchem man die PPT - Präsentation auswählen kann.
Diese soll dann geöffnet werden und das Makro soll jetzt laufen.
Danach soll PPT - Präsentation ohne zu speichern wieder geschlossen werden.
jetzt wird vor jedem Text auch noch das Rauter Zeichen geschrieben. Dieses soll wegfallen
und das ganz Letzte was ich noch hinkriegen müsste: in der PPT - Präsentation gibts teilweise auch Text mit Symbolartigen Pfeilchen (kleine Pfeile). Natürlich werden durchs Makro diese kleinen Pfeilchen nicht übernommen, sondern als willkürliche Zeichen ins Excel übertragen.
Bringt man das hin, dass diese Zeichen entweder richtig dargestellt werden oder weggelassen werden ?
HERZLICHEN DANK !
Anzeige
AW: Neues Posting: Code weiter ergänzen
20.03.2012 17:44:58
Pascal
Guten Abend zusammen
Kann man den Super - Code von Ransi irgendwie so anpassen....
Zuerst wird eine UserForm gestartet.
In der UserForm drin gibts ein Textfeld (da drin soll der Text welcher ab den PPT-Folien ausgelesen wird dargestellt werden)
Dann gibts einen OK und eine Abbrechen - Button
Wenn ich auf den OK - Button klicke, dann soll der Text ins Excel geschrieben werden. Und zum Nächsten Text gesprungen werden.
Wenn Abbrechen gedrückt wird, so soll direkt der nächste Datensatz (also der nächst Text) geholt- und ins Textfeld dargestellt werden.
Das Ganze soll über alle Folien und alle Texte (Loopartig) gemacht werden können.
Also Text um Text muss entschieden werden ob ins Excel kopiert wird oder nicht.
Geht das irgendwie ?
Bin für jeden Tip dankbar !
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige