23.02.2011

UPDATE! Excel - PowerPoint - Textfelder - Diagramm!

UPDATE!

Berechtigter Einwand: Das/die Diagramm(e) sollen entweder als Bild, oder als eingebettetes Objekt eingefügt werden. Damit die Übersicht gewahrt bleibt ein neuer Blogeintrag.

Hier der Link zum Vorhergehenden:
http://vbanet.blogspot.com/2011/02/excel-powerpoint-textfelder-diagramm.html

Immer wieder gefragt: Wie bekomme ich einen Bereich bzw. ein Diagramm in eine PowerPoint Datei, die auf einer Vorlage basiert? Für jedes Tabellenblatt soll eine Folie angelegt werden, bestimmte Werte in zu erzeugende Textfelder kopiert werden. Platzhalter bzw. Titel sollen befüllt werden. Dann soll noch das im jeweiligen Tabellenblatt eingebettete Diagramm auf die entsprechende Folie übernommen werden. Erstellt und getestet habe ich das in Excel 2010 (ergo die PowerPoint-Dateien in PP2010). Für andere Excel- PowerPointversionen müssen Änderungen vorgenommen werden. Insbesondere beim Dateinamen der Vorlage und in Excel 2003 darf das PowerPoint-Fenster NICHT ausgeblendet bleiben - das führt zu einem Fehler.

Excel - PowerPoint - Textfelder - Diagramm...[ZIP, 200 KB]

Code gehört in ein allgemeines Modul:
Option Explicit
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal _
hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal strBufferLength As Long, ByVal _
lpBuffer As String) As Long
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
Dim blnTMP As Boolean
Const strPPSave As String = "EXCELnachPP" ' anpassen!!!
Public Sub Test()
Dim objAppPraes As Object
Dim blnFrage As Boolean
Dim intSheet As Integer
Dim objShape As Object
Dim objSlide As Object
Dim objChart As Object
Dim intTMP As Integer
Dim objApp As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set objApp = OffApp("PowerPoint", False)
If Not objApp Is Nothing Then
Set objAppPraes = objApp.Presentations.Open _
(ThisWorkbook.Path & "\" & _
"TestVorlagePP2010.potx", Untitled:=msoCTrue)
Call PP_Klein
With objAppPraes
For Each objShape In .Slides(.Slides.Count).Shapes
' 3 = ppPlaceholderCenterTitle
' 4 = ppPlaceholderSubtitle
If objShape.PlaceHolderFormat.Type = 3 Then
objShape.TextFrame.TextRange.Text = _
Tabelle1.Range("A1").Text
ElseIf objShape.PlaceHolderFormat.Type = 4 Then
objShape.TextFrame.TextRange.Text = _
Tabelle1.Range("A2").Text
End If
Next objShape
' 11 = ppLayoutTitleOnly
Select Case MsgBox("Diagramm(e) als eingebettetes Objekt " & _
"""Ja klicken"" oder als Bild ""Nein klicken"" einfügen?", _
vbYesNo Or vbQuestion Or vbDefaultButton1, "Bild / Objekt?")
Case vbYes
blnFrage = True
Case vbNo
blnFrage = False
End Select
For intSheet = 1 To ThisWorkbook.Worksheets.Count
Set objSlide = .Slides.Add(.Slides.Count + 1, 11)
.Slides(.Slides.Count).Shapes.Title _
.TextFrame.TextRange.Text = _
ThisWorkbook.Worksheets(intSheet).Range("B1").Text
' 1 = msoShapeRectangle
For intTMP = 1 To 9
With objSlide.Shapes.AddShape(Type:=1, _
Top:=100 + 40 * intTMP, _
Left:=60, _
Width:=50, _
Height:=20)
.Name = "Text" & intTMP
.Fill.ForeColor.RGB = RGB(223, 223, 223)
' 1 = msoLineSolid
.Line.DashStyle = 1
With .TextFrame.TextRange
.Text = ThisWorkbook.Worksheets(intSheet) _
.Cells(intTMP, 8).Text
.Font.Color.RGB = RGB(0, 0, 128)
.Font.Name = "Arial"
.Font.Size = 12
End With
End With
Next intTMP
If blnFrage = True Then
ThisWorkbook.Worksheets(intSheet) _
.Shapes("TestChart").Copy
Set objChart = objSlide.Shapes.Paste
Else
ThisWorkbook.Worksheets(intSheet) _
.Shapes("TestChart").CopyPicture
' 3 = ppPasteMetafilePicture
Set objChart = objSlide.Shapes _
.PasteSpecial(DataType:=3)(1)
End If
With objChart
.Top = 140
.Left = 140
.Width = 520
.Height = 320
If blnFrage = True Then
.LinkFormat.BreakLink
End If
End With
Set objSlide = Nothing
Next intSheet
.SaveAs ThisWorkbook.Path & "\" & strPPSave
End With
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Set objSlide = Nothing
Set objAppPraes = Nothing
Set objApp = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function
Private Sub PP_Klein()
Dim hWindow As Long
hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
Call ShowWindow(hWindow, SW_MINIMIZE)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
Dim strTMP As String * 100
Dim nhWnd As Long
nhWnd = FindWindow(vbNullString, vbNullString)
Do While Not nhWnd = 0
If GetParent(nhWnd) = 0 Then
GetWindowText nhWnd, strTMP, 100
If InStr(strTMP, strSearch) > 0 Then
SearchHndByWndName_Parent = nhWnd
Exit Do
End If
End If
nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
Loop
End Function

Excel - PowerPoint - Textfelder - Diagramm!

Immer wieder gefragt: Wie bekomme ich einen Bereich bzw. ein Diagramm in eine PowerPoint Datei, die auf einer Vorlage basiert? Für jedes Tabellenblatt soll eine Folie angelegt werden, bestimmte Werte in zu erzeugende Textfelder kopiert werden. Platzhalter bzw. Titel sollen befüllt werden. Dann soll noch das im jeweiligen Tabellenblatt eingebettete Diagramm auf die entsprechende Folie übernommen werden. Erstellt und getestet habe ich das in Excel 2010 (ergo die PowerPoint-Dateien in PP2010). Für andere Excel- PowerPointversionen müssen Änderungen vorgenommen werden. Insbesondere beim Dateinamen der Vorlage und in Excel 2003 darf das PowerPoint-Fenster NICHT ausgeblendet bleiben - das führt zu einem Fehler.

Excel - PowerPoint - Textfelder - Diagramm...[ZIP, 200 KB]

Code gehört in ein allgemeines Modul:
Option Explicit
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal _
hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal strBufferLength As Long, ByVal _
lpBuffer As String) As Long
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
Dim blnTMP As Boolean
Const strPPSave As String = "EXCELnachPP" ' anpassen!!!
Public Sub Test()
Dim objAppPraes As Object
Dim intSheet As Integer
Dim objShape As Object
Dim objSlide As Object
Dim objChart As Object
Dim intTMP As Integer
Dim objApp As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set objApp = OffApp("PowerPoint", False)
If Not objApp Is Nothing Then
Set objAppPraes = objApp.Presentations.Open _
(ThisWorkbook.Path & "\" & _
"TestVorlagePP2010.potx", Untitled:=msoCTrue)
Call PP_Klein
With objAppPraes
For Each objShape In .Slides(.Slides.Count).Shapes
' 3 = ppPlaceholderCenterTitle
' 4 = ppPlaceholderSubtitle
If objShape.PlaceHolderFormat.Type = 3 Then
objShape.TextFrame.TextRange.Text = _
Tabelle1.Range("A1").Text
ElseIf objShape.PlaceHolderFormat.Type = 4 Then
objShape.TextFrame.TextRange.Text = _
Tabelle1.Range("A2").Text
End If
Next objShape
' 11 = ppLayoutTitleOnly
For intSheet = 1 To ThisWorkbook.Worksheets.Count
Set objSlide = .Slides.Add(.Slides.Count + 1, 11)
.Slides(.Slides.Count).Shapes.Title _
.TextFrame.TextRange.Text = _
ThisWorkbook.Worksheets(intSheet).Range("B1").Text
' 1 = msoShapeRectangle
For intTMP = 1 To 9
With objSlide.Shapes.AddShape(Type:=1, _
Top:=100 + 40 * intTMP, _
Left:=60, _
Width:=50, _
Height:=20)
.Name = "Text" & intTMP
.Fill.ForeColor.RGB = RGB(223, 223, 223)
' 1 = msoLineSolid
.Line.DashStyle = 1
With .TextFrame.TextRange
.Text = ThisWorkbook.Worksheets(intSheet) _
.Cells(intTMP, 8).Text
.Font.Color.RGB = RGB(0, 0, 128)
.Font.Name = "Arial"
.Font.Size = 12
End With
End With
Next intTMP
ThisWorkbook.Worksheets(intSheet) _
.Shapes("TestChart").CopyPicture
' 3 = ppPasteMetafilePicture
Set objChart = objSlide.Shapes _
.PasteSpecial(DataType:=3)(1)
With objChart
.Top = 140
.Left = 140
.Width = 520
.Height = 320
End With
Next intSheet
.SaveAs ThisWorkbook.Path & "\" & strPPSave
End With
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Set objSlide = Nothing
Set objAppPraes = Nothing
Set objApp = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function
Private Sub PP_Klein()
Dim hWindow As Long
hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
Call ShowWindow(hWindow, SW_MINIMIZE)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
Dim strTMP As String * 100
Dim nhWnd As Long
nhWnd = FindWindow(vbNullString, vbNullString)
Do While Not nhWnd = 0
If GetParent(nhWnd) = 0 Then
GetWindowText nhWnd, strTMP, 100
If InStr(strTMP, strSearch) > 0 Then
SearchHndByWndName_Parent = nhWnd
Exit Do
End If
End If
nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
Loop
End Function

08.02.2011

Namen - RefersTo - RefersTo Range - auslesen!

Frage: In Tabellenblättern ist einer Zelle oder einem Range ein Name zugeordnet. Auf einem neuen Tabellenblatt sollen nun die Werte der Namen und die Zugehörigkeit ausgegeben werden:

Namen - RefersTo - RefersTo Range - auslesen...[ZIP, 50 KB]

Code gehört in ein allgemeines Modul:
Option Explicit
Public Sub Eine_Zelle()
Dim blnFrage As Boolean
Dim intCount As Integer
Dim nmName As Name
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Worksheets.Add After:=Sheets(Sheets.Count)
For Each nmName In ThisWorkbook.Names
If LCase(nmName.Name) Like "*nettopreis" Then
With ActiveSheet
.Cells(intCount + 1, 1).Value = _
nmName.RefersToRange.Text
.Cells(intCount + 1, 2).Value = _
nmName.RefersTo
.Cells(intCount + 1, 3).Value = _
nmName.Name
intCount = intCount + 1
blnFrage = True
End With
End If
Next nmName
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
If Not blnFrage Then ActiveSheet.Delete
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Public Sub Einen_Range()
Dim blnFrage As Boolean
Dim intCount As Integer
Dim intTMP As Integer
Dim nmName As Name
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Worksheets.Add After:=Sheets(Sheets.Count)
For Each nmName In ThisWorkbook.Names
If LCase(nmName.Name) Like "*netto*" Then
If nmName.RefersToRange.Count > 1 Then
For intTMP = 1 To nmName.RefersToRange.Count
With ActiveSheet
.Cells(intCount + 1, 1).Value = _
nmName.RefersToRange.Cells _
(intTMP).Value
.Cells(intCount + 1, 2).Value = _
nmName.RefersTo
.Cells(intCount + 1, 3).Value = _
nmName.Name
intCount = intCount + 1
blnFrage = True
End With
Next intTMP
Else
With ActiveSheet
.Cells(intCount + 1, 1).Value = _
nmName.RefersToRange.Text
.Cells(intCount + 1, 2).Value = _
nmName.RefersTo
.Cells(intCount + 1, 3).Value = _
nmName.Name
intCount = intCount + 1
blnFrage = True
End With
End If
End If
Next nmName
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
If Not blnFrage Then ActiveSheet.Delete
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

02.02.2011

Datei - Zelle auslesen - Dialog!

Frage: Wie kann man aus einer Datei die über einen Dateiauswahldialog auszuwählen ist eine Zelle in eine Übersicht kopieren. Es soll die Möglichkeit bestehen das Tabellenblatt auszuwählen. Die Zelle wird über eine InputBox das Tabellenblatt über eine UserForm abgefragt.

Datei - Zelle auslesen - Dialog - Tabellenblattauswahl...[ZIP, 80 KB]

Code gehört in "UsrForm1":
Option Explicit
Private Sub UserForm_Activate()
ComboBox1.ListIndex = 0
End Sub
Private Sub CommandButton1_Click()
Me.Tag = ComboBox1.Value
Me.Hide
End Sub

Code gehört in ein allgemeines Modul:
Option Explicit
Public Sub Test()
Dim wksSheetZ As Worksheet
Dim wksSheet As Worksheet
Dim wkbBook As Workbook
Dim strCell As String
Dim lngColumn As Long
Dim strTMP As String
Dim lngRow As Long
On Error GoTo Fin:
lngRow = ActiveCell.Row
lngColumn = ActiveCell.Column
strCell = InputBox("Zelle", "Eingabe", "A4")
If Trim(strCell) = "" Then Exit Sub
Application.ScreenUpdating = False
If GetAFile(strTMP) <> "" Then
' Tabellenblattname "Gesamt" bei Bedarf anpassen!!!!
Set wksSheetZ = ThisWorkbook.Worksheets("Gesamt")
Set wkbBook = Workbooks.Open(Dir(strTMP))
For Each wksSheet In wkbBook.Worksheets
UserForm1.ComboBox1.AddItem (wksSheet.Name)
Next wksSheet
UserForm1.Show
Set wksSheet = wkbBook.Worksheets(UserForm1.Tag)
With wksSheet
If .Range(strCell).Value <> "" Then
.Range(strCell).Copy _
wksSheetZ.Cells(lngRow, lngColumn)
'Oder NUR WERT übertragen!!!!
'wksSheetZ.Cells(lngRow, lngColumn) = _
.Range(strCell).Value
Else
wksSheetZ.Cells(lngRow, lngColumn).Value = _
"Zelle ohne Inhalt!"
End If
End With
Else
MsgBox "Keine Datei ausgewählt!"
End If
Fin:
Application.CutCopyMode = False
Set wksSheetZ = Nothing
Set wksSheet = Nothing
If Not wkbBook Is Nothing Then wkbBook.Close False
Set wkbBook = Nothing
Application.ScreenUpdating = True
Unload UserForm1
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function GetAFile(strFile As String) As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Datei"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewDetails
If .Show = -1 Then
strFile = .SelectedItems(1)
Else
strFile = ""
End If
End With
GetAFile = strFile
End Function

Word - Kontrollkästchen (Formularsteuerelement) auslesen...

Aus allen Worddateien sollen die Kontrollkästchen (Formularsteuerelement) ausgelesen werden - Haken gesetzt oder nicht. Auch ein Textfeld (F...