使用 Excel vba 将 objects 放入 PowerPoint table
Using Excel vba to put objects in PowerPoint table
我正在使用 Excel 工作表在 PowerPoint 中填充会议日程。我的 excel 文件包含 a 到 f 列（会议名称、地点、类别（会议由哪个员工部门负责）、星期几、一天中的时间和会议时长）。工作表的 headers 位于第 4 行，因此数据从第 5 行开始。此数据用于将 PowerPoint 形状放入幻灯片的 table 中。我有一个名为 BREpptObjects 的 class object，它有 BREpptObjectName As String, BREpptObjectLocation As String, BREpptObjectCategory As String, BREpptObjectDays as String, BREpptObjectTime As Integer, BREpptObjectLength As Double, BREpptObjectPIC As Integer。 PIC 应该位于同一单元格中多个 object 的单元格中。所有的 Gets 和 Lets 也被编码。为简洁起见，将其省略。
我的电子表格上有一个用于启动导出的命令按钮。问题是如果同时有多个会议，我的形状就会堆叠在一起。对于我的生活，我无法弄清楚如何抵消或消除堆叠形状的冲突。任何帮助将不胜感激。
Sub ExportToPPTButton_Click()
Dim BREobjects() As BREpptObjects
Dim BREdaysString() As String
Dim BREppt As PowerPoint.Presentation
Dim BREpptURL As String
Dim PowerPointApp As PowerPoint.Application
Dim BREpptLayout As CustomLayout
Dim NewBREslide As Slide
Dim BREtable As PowerPoint.Shape
Dim BREbubble As PowerPoint.Shape
Dim BREdtg As Range
Dim placeInCell As Integer
Dim lastrow As Integer
Dim BREitems as Range
Dim yy As Single
Dim xx As Single
Dim dx As Single
Dim dy As Single
Dim count As Integer
Dim objInCell As Integer
Dim daysAsInt As Integer
Dim BREname As String
Dim BRELocation As String
Dim BREcategory As String
Dim BREtime As Long
Dim BRElength As Double
Dim BREdays As String
BREpptURL = "https://MyURL.com"
Set PowerPointApp = CreateObject("PowerPoint.Application")
Set BREppt = PowerPointApp.Presentations.Open(BREpptURL)
Set BREpptLayout = BREppt.Slides(1).CustomLayout
Set NewBREslide = BREppt.Slides.AddSlide(1, BREpptLayout)
Set BREtable = BREppt.Slides(2).Shapes("BREslideTable")
lastrow = Cells(Rows.count, "a").End(xlUp).Row
Set BREitems = Range("a5:a" & lastrow)
BREtable.Copy
BREppt.Slides(1).Shapes.Paste
BREppt.Slides(1).Select
Set NewBREslide = BREppt.Slides(1)
Set BREtable = BREppt.Slides(1).Shapes("BREslideTable")
placeInCell = 0
For Each i In BREitems
ReDim Preserve BREobjects(i.Row - 4)
Set BREobjects(i.Row - 4) = New BREpptObjects
With BREobjects(i.Row - 4)
.BREname = Cells(i.row, "a").value
.BRELocation = Cells(i.row, "b").value
.BREcategory = Cells(i.row, "c").value
.BREdays = Cells(i.row, "d").value
.BREtime = (Cells(i.row, "e").value / 100) + 2 'this sets the time to equal the row number in the powerpoint table
.BRElength = Cells(i.row, "f").value
End With
BREname = BREobjects(i.Row - 4).BREname
BRELocation = BREobjects(i.Row - 4).BRELocation
BREcategory = BREobjects(i.Row - 4).BREcategory
BREtime = BREobjects(i.Row - 4).BREtime
BRElength = BREobjects(i.Row - 4).BRElength
BREdays = BREobjects(i.Row - 4).BREdays
yy = BREtable.Table.Cell(BREtime, 4).Shape.Top
dy = BREtable.Table.Cell(BRetime, 4).Shape.Height * BRElength
Set BREdtg = Range("d5:d" & lastrow)
BREdaysString() = Split(BREdays, ", ")
count = 0
For Each j In BREdaysString
Dim BREcompareString1 As String
BREcompareString1 = "*" & j & "*"
objInCell = 0
For Each k in BREdtg
Dim BREcompareTime As Long
Dim BREcompareString2 As String
BREcompareTime = (Cells(k.row, "e").value / 100) + 2
BREcompareString2 = k.value
If UCase(BRecompareString2) Like UCase(BREcompareString1) And BREtime = BREcompareTime Then
objInCell = objInCell + 1
End If
Next k
If objInCell = 1 Then
BREobjects(i.Row - 4).BREpic = 1
ElseIf objInCell > 1 Then
count = count + 1
BREobjects(i.Row - 4).BREpic = objInCell 'I know this causes the stacking but everything else I've tried blows us all the other powerpoint bubbles.
End If 'I feel like the count integer could be used somehow to set the BREpic but I can't figure out the loops.
If j = "Monday" Then 'This will set the column number in the table for the objects.
daysAsInt = 4
ElseIf j = "Tuesday" Then
daysAsInt = 5
ElseIf j = "Wednesday" Then
daysAsInt = 6
ElseIf j = "Thursday" Then
daysAsInt = 7
ElseIf j = "Friday" Then
daysAsInt = 8
ElseIf j = "Saturday" Then
daysAsInt = 9
ElseIf j = "Sunday" Then
daysAsInt = 10
End If
dx = BREtable.Table.Columns(4).Width / objInCell
If BREobjects(i.Row - 4).BREpic = 1 Then
xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left
ElseIf BREobjects(i.Row - 4).BREpic > 1 Then
xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left + (dx * BREobjects(i.Row - 4).BREpic) - dx
End If
Set BREbubble = NewBREslide.Shapes.AddShape(msoShapeRoundedRectable, xx, yy, dx, dy)
With BREbubble
.Name = BREname
.TextFrame.TextRange.Text = BREname
End With
Next j
Erase BREdaysString
Next i
End Sub
好吧，我的电脑丢给帮助台大约一个月了。终于拿回来了，大约一个星期前。当我的电脑被隔离时，我的灯泡熄灭了。花了大约半天的时间来实现我的想法并让这段代码起作用。为简洁起见，我不会 post BREpptObject class，但它都包含适当的 Gets 和 Lets。解决方法如下：
Sub ExportToPPTButton_Click()
Dim BREppt As PowerPoint.Presentation
Dim BREpptURL As String
Dim PowerPointApp As PowerPoint.Application
Dim BREpptLayout As CustomLayout
Dim NewBREslide As Slide
Dim BREtable As PowerPoint.Shape
Dim BREbubble As PowerPoint.Shape
Dim BREdtg As Range
Dim yy As Single
Dim dy As Single
BREpptURL = "https://SHAREPOINT.URL"
Set PowerPointApp = CreateObject("PowerPoint.Application")
Set BREppt = PowerPoint.Presentations.Open(BREpptURL)
Set BREpptLayout = BREppt.Slides(1).CustomLayout
Set NewBREslide = BREppt.Slides.AddSlide(1, BREpptLayout)
Set BREtable = BREppt.Slides(2).Shapes("BREslideTable")
Set BREdata = Range("a5:f" & lastrow)
Set BREitems = Range("a5:a" & lastrow)
BREtable.Copy
BREpptSlides(1).Shapes.Paste
BREppt.Slides(1).Select
Set NewBREslide = BREppt.Slides(1)
Set BREtable = BREppt.Slides(1).Shapes("BREslideTable")
'creates a new object for each BRE day/time comvination
count = 0
For Each i In BREitems
BREdaysString() = Split(Cells(i.Row, "d"), ", ")
For Each j In BREdaysString
count = count + 1
ReDim Preserve BREopbjects(count)
Set BREobjects(count) = New BREpptObjects
With BREobjects(count)
.BREname = Cells(i.Row, "a").value
.BRELocation = Cells(i.Row, "b").value
.BRECategory = Cells(i.Row, "c").value
.BREdays = j
.BREtime = (Cells(i.Row, "e").value / 100) + 2
.BRElength = Cells(i.Row, "f").value
End With
Next j
Erase BREdaysString
Next i
'compares each BREobject to all other BREobjects to determine how many and which are in the same day/time
For i = 1 To UBound(BREobjects)
BREname = BREobjects(i).BREname
BRELocation = BREobjects(i).BRELocation
BRECategory = BREobjects(i).BRECategory
BREtime = BREobjects(i).BREtime
BRElength = BREobjects(i).Length
BREdays = BREobjects(i).BREdays
If IsEmpty(BREobjects(i).BREpic) Then
BREobjects(i).BREpic = 0
End If
objInCell = 0
For j = 1 To UBoung(BREobjects)
BREnameComapre = BREobjects(j).BREname
BRELocationComapre = BREobjects(j).BRELocation
BRECategoryComapre = BREobjects(j).BRECategory
BREtimeComapre = BREobjects(j).BREtime
BRElengthComapre = BREobjects(j).Length
BREdaysComapre = BREobjects(j).BREdays
If BREdaysCompare = BREdays And BREtimeCompare = BREtime Then 'Sets place in cell (PIC) for each objects
objInCell = objInCell + 1
BREobjects(j).BREpic = objInCell
End If
Next j
BREobjects(i).BREobjInCell = objInCell 'Sets total # of objects in cell
Next i
'Converts day of the week to column number and creates bubbles for ppt slide
For i = 1 To UBound(BREobjects) - LBound(BREobjects)
BREdays = BREobjects(i).BREdays
BREpic = BREobjects(i).BREpic
BREtime = BREobjects(i).BREtime
BRECategory = BREobjects(i).BRECategory
BREname = BREobjects(i).BREname
objInCell = BREobjects(i).objInCell
If BREdays = "Monday" Then
daysAsInt = 4
ElseIf BREdays = "Tuesday" Then
daysAsInt = 5
ElseIf BREdays = "Wednesday" Then
daysAsInt = 6
ElseIf BREdays = "Thursday" Then
daysAsInt = 7
ElseIf BREdays = "Friday" Then
daysAsInt = 8
ElseIf BREdays = "Saturday" Then
daysAsInt = 9
ElseIf BREdays = "Sunday" Then
daysAsInt = 10
End If
yy = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Top
dy = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Height * BRElength
dx = BREtable.Table.Columns(daysAsInt).Width / objInCell
If objInCell = 1 Then
xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left
ElseIf objInCell > 1 Then
xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left + (dx * BREpic) - dx
End If
Set BREbubble = NewBREslide.Shapes.AddShape(msoShapeRoundedRectangle, xx, yy, dx, dy)
With BREbubble
.Name = BREname
.TextFrame.TextRange.Text = BREname
.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End With
If BRECategory = "CENTCOM" Then
BREbubble.Fill.ForeColor.RGB = RGB(112, 48, 160)
BREbubble.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
ElseIf BRECategory = "CG Chair" Then
BREbubble.Fill.ForeColor.RGB = RGB(255, 0, 0)
BREbubble.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
ElseIf BRECategory = "GO Chair" Then
BREbubble.Fill.ForeColor.RGB = RGB(255, 204, 0)
BREbubble.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)
ElseIf BRECategory = "Staff Chair" Then
BREbubble.Fill.ForeColor.RGB = RGB(146, 208, 80)
BREbubble.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)
End If
Next i
End Sub
我正在使用 Excel 工作表在 PowerPoint 中填充会议日程。我的 excel 文件包含 a 到 f 列（会议名称、地点、类别（会议由哪个员工部门负责）、星期几、一天中的时间和会议时长）。工作表的 headers 位于第 4 行，因此数据从第 5 行开始。此数据用于将 PowerPoint 形状放入幻灯片的 table 中。我有一个名为 BREpptObjects 的 class object，它有 BREpptObjectName As String, BREpptObjectLocation As String, BREpptObjectCategory As String, BREpptObjectDays as String, BREpptObjectTime As Integer, BREpptObjectLength As Double, BREpptObjectPIC As Integer。 PIC 应该位于同一单元格中多个 object 的单元格中。所有的 Gets 和 Lets 也被编码。为简洁起见，将其省略。
我的电子表格上有一个用于启动导出的命令按钮。问题是如果同时有多个会议，我的形状就会堆叠在一起。对于我的生活，我无法弄清楚如何抵消或消除堆叠形状的冲突。任何帮助将不胜感激。
Sub ExportToPPTButton_Click()
Dim BREobjects() As BREpptObjects
Dim BREdaysString() As String
Dim BREppt As PowerPoint.Presentation
Dim BREpptURL As String
Dim PowerPointApp As PowerPoint.Application
Dim BREpptLayout As CustomLayout
Dim NewBREslide As Slide
Dim BREtable As PowerPoint.Shape
Dim BREbubble As PowerPoint.Shape
Dim BREdtg As Range
Dim placeInCell As Integer
Dim lastrow As Integer
Dim BREitems as Range
Dim yy As Single
Dim xx As Single
Dim dx As Single
Dim dy As Single
Dim count As Integer
Dim objInCell As Integer
Dim daysAsInt As Integer
Dim BREname As String
Dim BRELocation As String
Dim BREcategory As String
Dim BREtime As Long
Dim BRElength As Double
Dim BREdays As String
BREpptURL = "https://MyURL.com"
Set PowerPointApp = CreateObject("PowerPoint.Application")
Set BREppt = PowerPointApp.Presentations.Open(BREpptURL)
Set BREpptLayout = BREppt.Slides(1).CustomLayout
Set NewBREslide = BREppt.Slides.AddSlide(1, BREpptLayout)
Set BREtable = BREppt.Slides(2).Shapes("BREslideTable")
lastrow = Cells(Rows.count, "a").End(xlUp).Row
Set BREitems = Range("a5:a" & lastrow)
BREtable.Copy
BREppt.Slides(1).Shapes.Paste
BREppt.Slides(1).Select
Set NewBREslide = BREppt.Slides(1)
Set BREtable = BREppt.Slides(1).Shapes("BREslideTable")
placeInCell = 0
For Each i In BREitems
ReDim Preserve BREobjects(i.Row - 4)
Set BREobjects(i.Row - 4) = New BREpptObjects
With BREobjects(i.Row - 4)
.BREname = Cells(i.row, "a").value
.BRELocation = Cells(i.row, "b").value
.BREcategory = Cells(i.row, "c").value
.BREdays = Cells(i.row, "d").value
.BREtime = (Cells(i.row, "e").value / 100) + 2 'this sets the time to equal the row number in the powerpoint table
.BRElength = Cells(i.row, "f").value
End With
BREname = BREobjects(i.Row - 4).BREname
BRELocation = BREobjects(i.Row - 4).BRELocation
BREcategory = BREobjects(i.Row - 4).BREcategory
BREtime = BREobjects(i.Row - 4).BREtime
BRElength = BREobjects(i.Row - 4).BRElength
BREdays = BREobjects(i.Row - 4).BREdays
yy = BREtable.Table.Cell(BREtime, 4).Shape.Top
dy = BREtable.Table.Cell(BRetime, 4).Shape.Height * BRElength
Set BREdtg = Range("d5:d" & lastrow)
BREdaysString() = Split(BREdays, ", ")
count = 0
For Each j In BREdaysString
Dim BREcompareString1 As String
BREcompareString1 = "*" & j & "*"
objInCell = 0
For Each k in BREdtg
Dim BREcompareTime As Long
Dim BREcompareString2 As String
BREcompareTime = (Cells(k.row, "e").value / 100) + 2
BREcompareString2 = k.value
If UCase(BRecompareString2) Like UCase(BREcompareString1) And BREtime = BREcompareTime Then
objInCell = objInCell + 1
End If
Next k
If objInCell = 1 Then
BREobjects(i.Row - 4).BREpic = 1
ElseIf objInCell > 1 Then
count = count + 1
BREobjects(i.Row - 4).BREpic = objInCell 'I know this causes the stacking but everything else I've tried blows us all the other powerpoint bubbles.
End If 'I feel like the count integer could be used somehow to set the BREpic but I can't figure out the loops.
If j = "Monday" Then 'This will set the column number in the table for the objects.
daysAsInt = 4
ElseIf j = "Tuesday" Then
daysAsInt = 5
ElseIf j = "Wednesday" Then
daysAsInt = 6
ElseIf j = "Thursday" Then
daysAsInt = 7
ElseIf j = "Friday" Then
daysAsInt = 8
ElseIf j = "Saturday" Then
daysAsInt = 9
ElseIf j = "Sunday" Then
daysAsInt = 10
End If
dx = BREtable.Table.Columns(4).Width / objInCell
If BREobjects(i.Row - 4).BREpic = 1 Then
xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left
ElseIf BREobjects(i.Row - 4).BREpic > 1 Then
xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left + (dx * BREobjects(i.Row - 4).BREpic) - dx
End If
Set BREbubble = NewBREslide.Shapes.AddShape(msoShapeRoundedRectable, xx, yy, dx, dy)
With BREbubble
.Name = BREname
.TextFrame.TextRange.Text = BREname
End With
Next j
Erase BREdaysString
Next i
End Sub
好吧，我的电脑丢给帮助台大约一个月了。终于拿回来了，大约一个星期前。当我的电脑被隔离时，我的灯泡熄灭了。花了大约半天的时间来实现我的想法并让这段代码起作用。为简洁起见，我不会 post BREpptObject class，但它都包含适当的 Gets 和 Lets。解决方法如下：
Sub ExportToPPTButton_Click()
Dim BREppt As PowerPoint.Presentation
Dim BREpptURL As String
Dim PowerPointApp As PowerPoint.Application
Dim BREpptLayout As CustomLayout
Dim NewBREslide As Slide
Dim BREtable As PowerPoint.Shape
Dim BREbubble As PowerPoint.Shape
Dim BREdtg As Range
Dim yy As Single
Dim dy As Single
BREpptURL = "https://SHAREPOINT.URL"
Set PowerPointApp = CreateObject("PowerPoint.Application")
Set BREppt = PowerPoint.Presentations.Open(BREpptURL)
Set BREpptLayout = BREppt.Slides(1).CustomLayout
Set NewBREslide = BREppt.Slides.AddSlide(1, BREpptLayout)
Set BREtable = BREppt.Slides(2).Shapes("BREslideTable")
Set BREdata = Range("a5:f" & lastrow)
Set BREitems = Range("a5:a" & lastrow)
BREtable.Copy
BREpptSlides(1).Shapes.Paste
BREppt.Slides(1).Select
Set NewBREslide = BREppt.Slides(1)
Set BREtable = BREppt.Slides(1).Shapes("BREslideTable")
'creates a new object for each BRE day/time comvination
count = 0
For Each i In BREitems
BREdaysString() = Split(Cells(i.Row, "d"), ", ")
For Each j In BREdaysString
count = count + 1
ReDim Preserve BREopbjects(count)
Set BREobjects(count) = New BREpptObjects
With BREobjects(count)
.BREname = Cells(i.Row, "a").value
.BRELocation = Cells(i.Row, "b").value
.BRECategory = Cells(i.Row, "c").value
.BREdays = j
.BREtime = (Cells(i.Row, "e").value / 100) + 2
.BRElength = Cells(i.Row, "f").value
End With
Next j
Erase BREdaysString
Next i
'compares each BREobject to all other BREobjects to determine how many and which are in the same day/time
For i = 1 To UBound(BREobjects)
BREname = BREobjects(i).BREname
BRELocation = BREobjects(i).BRELocation
BRECategory = BREobjects(i).BRECategory
BREtime = BREobjects(i).BREtime
BRElength = BREobjects(i).Length
BREdays = BREobjects(i).BREdays
If IsEmpty(BREobjects(i).BREpic) Then
BREobjects(i).BREpic = 0
End If
objInCell = 0
For j = 1 To UBoung(BREobjects)
BREnameComapre = BREobjects(j).BREname
BRELocationComapre = BREobjects(j).BRELocation
BRECategoryComapre = BREobjects(j).BRECategory
BREtimeComapre = BREobjects(j).BREtime
BRElengthComapre = BREobjects(j).Length
BREdaysComapre = BREobjects(j).BREdays
If BREdaysCompare = BREdays And BREtimeCompare = BREtime Then 'Sets place in cell (PIC) for each objects
objInCell = objInCell + 1
BREobjects(j).BREpic = objInCell
End If
Next j
BREobjects(i).BREobjInCell = objInCell 'Sets total # of objects in cell
Next i
'Converts day of the week to column number and creates bubbles for ppt slide
For i = 1 To UBound(BREobjects) - LBound(BREobjects)
BREdays = BREobjects(i).BREdays
BREpic = BREobjects(i).BREpic
BREtime = BREobjects(i).BREtime
BRECategory = BREobjects(i).BRECategory
BREname = BREobjects(i).BREname
objInCell = BREobjects(i).objInCell
If BREdays = "Monday" Then
daysAsInt = 4
ElseIf BREdays = "Tuesday" Then
daysAsInt = 5
ElseIf BREdays = "Wednesday" Then
daysAsInt = 6
ElseIf BREdays = "Thursday" Then
daysAsInt = 7
ElseIf BREdays = "Friday" Then
daysAsInt = 8
ElseIf BREdays = "Saturday" Then
daysAsInt = 9
ElseIf BREdays = "Sunday" Then
daysAsInt = 10
End If
yy = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Top
dy = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Height * BRElength
dx = BREtable.Table.Columns(daysAsInt).Width / objInCell
If objInCell = 1 Then
xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left
ElseIf objInCell > 1 Then
xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left + (dx * BREpic) - dx
End If
Set BREbubble = NewBREslide.Shapes.AddShape(msoShapeRoundedRectangle, xx, yy, dx, dy)
With BREbubble
.Name = BREname
.TextFrame.TextRange.Text = BREname
.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End With
If BRECategory = "CENTCOM" Then
BREbubble.Fill.ForeColor.RGB = RGB(112, 48, 160)
BREbubble.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
ElseIf BRECategory = "CG Chair" Then
BREbubble.Fill.ForeColor.RGB = RGB(255, 0, 0)
BREbubble.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
ElseIf BRECategory = "GO Chair" Then
BREbubble.Fill.ForeColor.RGB = RGB(255, 204, 0)
BREbubble.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)
ElseIf BRECategory = "Staff Chair" Then
BREbubble.Fill.ForeColor.RGB = RGB(146, 208, 80)
BREbubble.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)
End If
Next i
End Sub