Clever-Excel-Forum

Hallo,

ich habe ein Makro geschrieben, dass mir automatisch eine PowerPoint erstellt mit den Inhalten der Exceldatei. 

Jeder Text in Excel ist noch einer Kategorie zugeordnet und ich möchte jetzt, dass mein Makro liest welche Kategorie dort steht und dann das Textfeld in PowerPoint dem entsprechend Färbt. 

Leider habe ich keine Ahnung wie das funktioniert.  

(Für genauere Erklärung einfach fragen, ich gebe mein bestes    )


Ich hoffe mir kann jemand helfen. 

Vielen Dank und viele Grüße

Baummaster

Hallöchen,

zeichne den code zum Färben in Excel auf und passe ihn auf die Powerpoint-Textbox an.

Hey, 

danke schonmal für deine Hilfe. 

Ich habe es heute mal probiert aber kriege es irgendwie nicht richtig hin. Kannst du mir vielleicht ein Beispiel geben?

VG
Baummaster

Hallo,

hier ein Beispiel:
[attachment=38618]

Wow!
Perfekt vielen Dank für deine ausführliche und vor allem schnelle Hilfe.

Ich konnte auch nochmal einiges in mein Makro übernehmen. Ich kopiere meins mal hier rein aber bitte nicht auslachen, es geht 100% besser. (Habe einen für das Thema irrelevanten Teil rausgelöscht, also nicht wundern wenn es komisch aussieht)


Danke nochmal und VG
Baummaster



Dim i As Integer
Dim x As Integer
Dim ppPotx As String
Dim ppPfad As String
Dim PP As Object
Dim PPP As Presentation
Dim intLeft As Integer
Dim intTop As Integer
Dim Height As Integer
Dim Width As Integer


ppPfad = "D:\Arbeit Makro\Layout\"
ppPotx = "Leiterrunde.potx"
Height = 60
Width = 100
Count = 10
intLeft = 10
intTop = 10
x = 7

Set PP = New PowerPoint.Application

Vorlage = ppPfad & ppPotx
PP.Presentations.Open Filename:=Vorlage, untitled:=msotrue

Set PPP = PP.ActivePresentation

x = 7
For i = 7 To 21
    If Workbooks("Makro.xlsm").Sheets("Tabelle1").Cells(i, 2).Value <> "" Then
        If Workbooks("Makro.xlsm").Sheets("Tabelle1").Cells(x, 3).Text = "reporting" Then
            With PPP.Slides(1).Shapes.AddShape(msoShapeRectangle, 0, 0, Width, Height)
                .TextFrame.TextRange.Characters.Text = Workbooks("Makro.xlsm").Sheets("Tabelle1").Cells(x, 2).Value
                .TextFrame.TextRange.Font.Size = 16
                .Top = Count
                .Left = intLeft
                .Fill.ForeColor.RGB = RGB(128, 0, 0)
            End With
            Else: With PPP.Slides(1).Shapes.AddShape(msoShapeRectangle, 0, 0, Width, Height)
                      .TextFrame.TextRange.Characters.Text = Workbooks("Makro.xlsm").Sheets("Tabelle1").Cells(x, 2).Value
                      .TextFrame.TextRange.Font.Size = 16
                      .Top = Count
                      .Left = intLeft
                      .Fill.ForeColor.RGB = RGB(100, 100, 100)
                  End With
        End If
        x = x + 1
        Count = Count + Height + intTop
    End If
   
Next i

x = 7
For i = 7 To 21
    If Workbooks("Makro.xlsm").Sheets("Tabelle1").Cells(i, 6).Value <> "" Then
        If Workbooks("Makro.xlsm").Sheets("Tabelle1").Cells(x, 7).Text = "reporting" Then
            With PPP.Slides(1).Shapes.AddShape(msoShapeRectangle, 0, 0, Width, Height)
                .TextFrame.TextRange.Characters.Text = Workbooks("Makro.xlsm").Sheets("Tabelle1").Cells(x, 6).Value
                .TextFrame.TextRange.Font.Size = 16
                .Top = Count
                .Left = intLeft
                .Fill.ForeColor.RGB = RGB(128, 0, 0)
            End With
            Else: With PPP.Slides(1).Shapes.AddShape(msoShapeRectangle, 0, 0, Width, Height)
                      .TextFrame.TextRange.Characters.Text = Workbooks("Makro.xlsm").Sheets("Tabelle1").Cells(x, 6).Value
                      .TextFrame.TextRange.Font.Size = 16
                      .Top = Count
                      .Left = intLeft
                      .Fill.ForeColor.RGB = RGB(100, 100, 100)
                  End With
        End If
        x = x + 1
        Count = Count + Height + intTop
    End If
   
Next i


PPP.SaveAs ppPfad & Workbooks("Makro.xlsm").Sheets("Tabelle1").Range("F1") & ".pptx"

If PP.Presentations.Count = 1 Then
    PPP.Close
    PP.Quit
    Else: PPP.Close
End If

Set PPP = Nothing
Set PP = Nothing

MsgBox ("End")

End Sub

Oder: