如何在PowerPoint中使用VBA将不同的Excel行粘贴到彼此顶部？

我有一个Excel 2013电子表格（使用Windows 10,64位），包含十五列和具有人员数据的variables行。 我的办公室正在将Excel中的各行按照PowerPoint中的形状进行剪贴，并通过划分来组织数据。 这是手动完成的。

我的同事手动通过数百行，没有任何VBA。

1. 从Excel中的第一行复制数据
2. 将其作为文本框或形状粘贴到PowerPoint中
3. 调整文本框的大小以适应自己的分区或列
4. 更改某些文本框的文本颜色和边框属性
5. 将文本框移到幻灯片上的所需位置
6. 重复下一行，直到完成。

VBA应该自动化这个过程。 最终的PowerPoint必须在单张幻灯片上显示组织结构图。 我的电脑屏幕上的文本框应该显得很小（几乎不可读）。 完美的海报大小打印出来。 为了testingVBA代码，我在单元格B2：O215中放置了随机数字。 在A栏中，我列出了“Div A”，“Div B”，…，“Div E”等各个部门的名称。 VBA应该：

1. 循环并复制Excel数据的每一行（从第2行开始）
2. 使用开关…案例来识别部门（例如案例“Div A”）
3. 使用案例“Div A”，将Excel行粘贴到幻灯片中的PowerPoint中
4. 使用案例“Div B”，将Excel数据粘贴到“Div A”右侧
5. 重复每个部门
6. 保持每个分部专栏之间的空间。
7. 每个数据形状的宽度应该是2“（所以2 * 72我认为）
8. 如果D列中的一个随机数字<0.2，则文字为红色

下面的代码将Excel数据叠加在一起，以便您不能看到它们。 我希望能够看到每个数据行看起来像一个表。 每一行都必须是明确的，所以领导才能移动它们。 有时，代码会过早停止。 最后，我不知道如何实现上面的第8步。

Sub ExcelRangeToPowerPoint() Dim PowerPointApp As Object Dim myPresentation As Object Dim mySlide As Object Dim myShape As Object 'Copy Range from Excel Sheets("Sheet1").Select ' Find the last row of data FinalRow = Cells(Rows.Count, 1).End(xlUp).Row 'Create an Instance of PowerPoint On Error Resume Next 'Is PowerPoint already opened? Set PowerPointApp = GetObject(class:="PowerPoint.Application") 'Clear the error between errors Err.Clear 'If PowerPoint is not already open then open PowerPoint If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application") 'Handle if the PowerPoint Application is not found If Err.Number = 429 Then MsgBox "PowerPoint could not be found, aborting." Exit Sub End If On Error GoTo 0 'Optimize Code Application.ScreenUpdating = False 'Create a New Presentation Set myPresentation = PowerPointApp.Presentations.Add 'Add a slide to the Presentation Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBlank 'Copy Excel Range ' Loop through each row For x = 2 To FinalRow ' Decide if to copy based not blank ThisValue = Cells(x, 1).Value If Not IsEmpty(ThisValue) Then 'Now the row is copied Cells(x, 1).Resize(1, 15).Copy Select Case ThisValue Case "Div A" 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 'Change the shape of the text box myShape.Left = 0.25 * 72 myShape.Top = myTop + 72 myShape.Width = 2 * 72 Case "Div B" 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 'Change the shape of the text box myShape.Left = 3 * 72 myShape.Top = myTop + 72 myShape.Width = 2 * 72 Case "Div C" 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 'Change the shape of the text box myShape.Left = 5 * 72 myShape.Top = myTop + 72 myShape.Width = 2 * 72 Case "Div D" 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 'Change the shape of the text box myShape.Left = 7 * 72 myShape.Top = myTop + 72 myShape.Width = 2 * 72 Case "Div E" 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 'Change the shape of the text box myShape.Left = 9 * 72 myShape.Top = myTop + 72 myShape.Width = 2 * 72 End Select End If Next x 'Make PowerPoint Visible and Active PowerPointApp.Visible = True PowerPointApp.Activate 'Clear The Clipboard Application.CutCopyMode = False NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 Cells(NextRow, 1).Select 'ActiveSheet.Paste Sheets("Sheet1").Select End Sub