VB/A: потоковая передача данных из Excel в PowerPoint

На этом изображении показано, как должен выглядеть конечный продукт: picture

  1. Есть таблица excel со строками и столбцами. В строках указаны СТРАНЫ. Столбцы - это ДАННЫЕ. Однако меня интересует только один столбец таблицы Excel.

  2. Как показано на изображении, стрелка указывает на страны, а затем создается эта таблица с «1» (1 — это просто тест, но, очевидно, это будут разные числа или что-то еще в электронной таблице Excel).

  3. У меня проблемы со следующими вещами:

    а. Я хочу создать шкалу: если целое число в столбце> 80, это будет зеленый фон. Если между 65-79, то он будет оранжевым. Если он ниже 65, он будет красным. Как вы можете видеть на изображении, которое я показал, весь фон таблицы просто зеленый. Я даже не знаю, почему он зеленый и почему он зеленый. Так что это одна проблема.

  4. Некоторые страны не работают должным образом. Стрелка не формируется, а таблица просто случайным образом появляется в случайном месте на карте.

Вот мой код:

Option Explicit

Public Const wkWhite            As Long = 16777215
Public Const wkBlack            As Long = 0
Public Const wkRed              As Long = 255
Public Const wkYellow           As Long = 65535
Public Const wkBlue             As Long = 13382451

Public Const wkColor_SCI        As Long = 10027161
Public Const wkColor_SCO        As Long = 16737792
Public Const wkColor_FIN        As Long = 65280
Public Const wkColor_BUY        As Long = 39270
Public Const wkColor_SPM        As Long = 39423
Public Const wkColor_QFS        As Long = 16776960

Public Const wkColor_DMD        As Long = 10027161
Public Const wkColor_SUP        As Long = 16737792
Public Const wkColor_SEQ        As Long = 65280
Public Const wkColor_IPO        As Long = 39270
Public Const wkColor_SOP        As Long = 39423
Public Const wkColor_OTH        As Long = 16776960

Public Const wkDeployedCol      As Long = 16737792
Public Const wkPartialCol       As Long = 39423
Public Const wkMatureCol        As Long = 65280

Public Const wkColor_EU         As Long = 13382451
Public Const wkColor_AM         As Long = 8421504
Public Const wkColor_AP         As Long = 153

Public Const wkLarg             As Single = 16
Public Const wkHaut             As Single = 12

Public Const wkSheet            As String = "Live Sites"
    '

Sub GenerateMap()

    DrawMap "Y"

End Sub

Sub UpdateMap()

    DrawMap "N"

End Sub

Sub DrawMap(ByVal parMode As String)

    Dim wkCnx               As ADODB.Connection
    Dim wkRS                As ADODB.Recordset
    Dim wkSQL               As String
    Dim wkFile              As String
    Dim wkActif             As String
    Dim wkSite              As String
    Dim i                   As Integer
    Dim j                   As Integer

    Dim wkColumn_Site       As Integer
    Dim wkColumn_Region     As Integer
    Dim wkColumn_Slide      As Integer
    Dim wkColumn_Left       As Integer
    Dim wkColumn_Top        As Integer
    Dim wkColumn_XBoard     As Integer
    Dim wkColumn_YBoard     As Integer
    Dim wkColumn_XSite      As Integer
    Dim wkColumn_YSite      As Integer
    Dim wkColumn_Activity   As Integer

    Dim wkColumn_SCI        As Integer
    Dim wkColumn_SCO        As Integer
    Dim wkColumn_FIN        As Integer
    Dim wkColumn_BUY        As Integer
    Dim wkColumn_SPM        As Integer
    Dim wkColumn_QFS        As Integer

    Dim wkColumn_DMD        As Integer
    Dim wkColumn_SUP        As Integer
    Dim wkColumn_SEQ        As Integer
    Dim wkColumn_IPO        As Integer
    Dim wkColumn_SOP        As Integer
    Dim wkColumn_OTH        As Integer

    Dim wkColumn_SOP_Plus   As Integer

    ScreenUpdating = False

    If parMode = "Y" Then CleanMap

    With Application.ActivePresentation
        wkFile = Replace(.Path & "\" & .Name, ".pptm", ".xlsx")
    End With
    Set wkCnx = New ADODB.Connection
    With wkCnx
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & wkFile & ";"
        .Properties("Extended Properties") = "Excel 12.0 Xml;HDR=NO;IMEX=1;"
        .Open
    End With

    Set wkRS = New ADODB.Recordset
    wkSQL = "SELECT * FROM [" & wkSheet & "$] WHERE F1<>'TITLE';"
    Set wkRS = wkCnx.Execute(wkSQL)

    For i = 0 To wkRS.Fields.Count - 1
        Select Case wkRS.Fields(i)
            Case "Site"
                wkColumn_Site = i
            Case "Region"
                wkColumn_Region = i
            Case "Slide"
                wkColumn_Slide = i
            Case "Top"
                wkColumn_Top = i
            Case "Left"
                wkColumn_Left = i
            Case "X_Board"
                wkColumn_XBoard = i
            Case "Y_Board"
                wkColumn_YBoard = i
            Case "X_Site"
                wkColumn_XSite = i
            Case "Y_Site"
                wkColumn_YSite = i
            Case "Activity"
                wkColumn_Activity = i
            Case "D-SCI"
                wkColumn_SCI = i
            Case "D-SCO"
                wkColumn_SCO = i
            Case "D-FIN"
                wkColumn_FIN = i
            Case "D-BUY"
                wkColumn_BUY = i
            Case "D-SPM"
                wkColumn_SPM = i
            Case "D-QFS"
                wkColumn_QFS = i
            Case "D-DMD"
                wkColumn_DMD = i
            Case "D-SUP"
                wkColumn_SUP = i
            Case "D-SEQ"
                wkColumn_SEQ = i
            Case "D-IPO"
                wkColumn_IPO = i
            Case "D-SOP"
                wkColumn_SOP = i
            Case "D-OTH"
                wkColumn_OTH = i
            Case "Self-Assessment Score (%)"
                wkColumn_SOP_Plus = i
            Case "External Audit Score (%)"
                wkColumn_SOP_Plus = i
        End Select
    Next i
    wkRS.MoveNext

    Progress.Show vbModeless

    Do While Not wkRS.EOF

        If IsNull(wkRS.Fields(wkColumn_Site)) Then
            wkSite = "site code unknown"
        Else
            wkSite = wkRS.Fields(wkColumn_Site)
        End If
        Progress.SiteTxt.Caption = wkSite

        wkActif = "Y"
        If wkRS.Fields(wkColumn_Slide) = 0 Then
            wkActif = "N"
        Else
            If parMode <> "Y" Then
                If UCase(wkRS.Fields(wkColumn_Activity)) <> "Y" Then
                    wkActif = "N"
                Else
                    For j = ActivePresentation.Slides.Count To 1 Step -1
                        For i = ActivePresentation.Slides(j).Shapes.Count To 1 Step -1
                            If (ActivePresentation.Slides(j).Shapes(i).Name Like wkRS.Fields(wkColumn_Site) & "_*") Then
                                ActivePresentation.Slides(j).Shapes(i).Delete
                            End If
                         Next i
                    Next j
                End If
            End If
        End If
        If wkActif = "Y" Then
'S&OP+ board
            DrawBoard "Self-Assessment Score (%)", _
                      wkRS.Fields(wkColumn_Slide), wkRS.Fields(wkColumn_Left), wkRS.Fields(wkColumn_Top), _
                      wkRS.Fields(wkColumn_Region), wkRS.Fields(wkColumn_Site), _
                      "Self-Assessment Score (%)", "", "", "", "", "", _
                      wkRS.Fields(wkColumn_SOP_Plus), "", "", "", "", "", _
                      wkRS.Fields(wkColumn_XBoard), wkRS.Fields(wkColumn_YBoard), wkRS.Fields(wkColumn_XSite), wkRS.Fields(wkColumn_YSite)
        End If
        wkRS.MoveNext
    Loop
    Unload Progress

    wkRS.Close
    Set wkRS = Nothing

    wkCnx.Close
    Set wkCnx = Nothing

    ScreenUpdating = True

End Sub

Sub DrawBoard(ByVal parProgram As String, _
              ByVal parSlide As Integer, _
              ByVal parLeft As Single, _
              ByVal parTop As Single, _
              ByVal parRegion As String, _
              ByVal parSite As String, _
              ByVal parAreaLogo1 As String, _
              ByVal parAreaLogo2 As String, _
              ByVal parAreaLogo3 As String, _
              ByVal parAreaLogo4 As String, _
              ByVal parAreaLogo5 As String, _
              ByVal parAreaLogo6 As String, _
              ByVal parAreaStatus1 As String, _
              ByVal parAreaStatus2 As String, _
              ByVal parAreaStatus3 As String, _
              ByVal parAreaStatus4 As String, _
              ByVal parAreaStatus5 As String, _
              ByVal parAreaStatus6 As String, _
              ByVal parXBoard As Single, _
              ByVal parYBoard As Single, _
              ByVal parXSite As Single, _
              ByVal parYSite As Single)

'draws the scoreboard of the site

    Dim wkColRegion As Long

'functional area frame
    If parProgram = "Self-Assessment Score (%)" Then
        DrawBoardArea parSlide, parLeft, parTop, parSite, parAreaLogo1, parAreaStatus1
    Else
        DrawBoardArea parSlide, parLeft, parTop, parSite, parAreaLogo1, parAreaStatus1
        DrawBoardArea parSlide, parLeft, parTop, parSite, parAreaLogo2, parAreaStatus2
        DrawBoardArea parSlide, parLeft, parTop, parSite, parAreaLogo3, parAreaStatus3
        DrawBoardArea parSlide, parLeft, parTop, parSite, parAreaLogo4, parAreaStatus4
        DrawBoardArea parSlide, parLeft, parTop, parSite, parAreaLogo5, parAreaStatus5
        DrawBoardArea parSlide, parLeft, parTop, parSite, parAreaLogo6, parAreaStatus6
    End If

'site frame
    wkColRegion = wkRed
    If "External Audit Score (%)" < 60 Then

    Select Case UCase(parRegion)
        Case "EU"
            wkColRegion = wkColor_EU
        Case "AM", "NA", "LA"
             wkColRegion = wkColor_AM
        Case "AP"
             wkColRegion = wkColor_AP
    End Select

    ActiveWindow.View.GotoSlide Index:=parSlide
    ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, parLeft, parTop + 2 * wkHaut, 3 * wkLarg, wkHaut).Select
    With ActiveWindow.Selection.ShapeRange
        .Name = parSite & "_" & parProgram & "_Site"
        .Fill.ForeColor.RGB = wkColRegion
        .Fill.BackColor.RGB = wkWhite
        .Fill.TwoColorGradient msoGradientVertical, 3
    End With

    ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
    With ActiveWindow.Selection.ShapeRange.TextFrame
        .MarginBottom = 0
        .MarginTop = 0
        .MarginLeft = 0
        .MarginRight = 0
        .HorizontalAnchor = msoAnchorCenter
        .VerticalAnchor = msoAnchorMiddle
    End With
    With ActiveWindow.Selection.TextRange
        .Text = parSite
        With .Font
            .Name = "Times New Roman"
            .Size = 8
            .Bold = msoTrue
        End With
    End With

'group area frames & site frame
    If parProgram = "Self-Assessment Score (%)" Then
        ActiveWindow.Selection.SlideRange.Shapes.Range(Array(parSite & "_" & parAreaLogo1, _
                                                             parSite & "_" & parProgram & "_Site")).Select
    Else
        ActiveWindow.Selection.SlideRange.Shapes.Range(Array(parSite & "_" & parAreaLogo1, _
                                                             parSite & "_" & parAreaLogo2, _
                                                             parSite & "_" & parAreaLogo3, _
                                                             parSite & "_" & parAreaLogo4, _
                                                             parSite & "_" & parAreaLogo5, _
                                                             parSite & "_" & parAreaLogo6, _
                                                             parSite & "_" & parProgram & "_Site")).Select
    End If
    ActiveWindow.Selection.ShapeRange.Group.Select
    ActiveWindow.Selection.ShapeRange.Select
    ActiveWindow.Selection.ShapeRange.Name = parSite & "_" & parProgram & "_Board"

'line
    If (parXSite <> 0) And (parYSite <> 0) Then
        ActiveWindow.Selection.SlideRange.Shapes.AddLine(parLeft + parXBoard, parTop + parYBoard, parXSite, parYSite).Select
        With ActiveWindow.Selection.ShapeRange
            .Line.ForeColor.RGB = wkBlue
            .Line.Weight = 1.5
            .ZOrder msoSendBackward
            .Select
            .Name = parSite & "_" & parProgram & "_Line"
        End With
    End If

    DoEvents

End Sub

Sub DrawBoardArea(ByVal parSlide As Integer, _
                  ByVal parLeft As Single, _
                  ByVal parTop As Single, _
                  ByVal parSite As String, _
                  ByVal parAreaLogo As String, _
                  ByVal parAreaStatus As String)

'draws the functional area status (text and color)

    Dim wkAreaLeft  As Single
    Dim wkAreaTop   As Single
    Dim wkCol       As Long
    Dim wkTxt       As String
    Dim wkColTxt    As Long
    Dim wkMonth     As String
     Dim x As Integer


    ActiveWindow.View.GotoSlide Index:=parSlide

    Select Case parAreaLogo
        Case "SCI", "BUY", "DMD", "IPO", "Self-Assessment Score (%)"
            wkAreaLeft = parLeft
        Case "SCO", "SPM", "SUP", "SOP"
             wkAreaLeft = parLeft + wkLarg
        Case "FIN", "QFS", "SEQ", "OTH"
             wkAreaLeft = parLeft + 2 * wkLarg
    End Select

    Select Case parAreaLogo
        Case "SCI", "SCO", "FIN", "DMD", "SUP", "SEQ", "Self-Assessment Score (%)"
            wkAreaTop = parTop
        Case "BUY", "SPM", "QFS", "IPO", "SOP", "OTH"
             wkAreaTop = parTop + wkHaut
    End Select

    If parAreaLogo = "Self-Assessment Score (%)" Then
        ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, wkAreaLeft, wkAreaTop, 3 * wkLarg, 2 * wkHaut).Select
    Else
        ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, wkAreaLeft, wkAreaTop, wkLarg, wkHaut).Select
    End If
    ActiveWindow.Selection.ShapeRange.Name = parSite & "_" & parAreaLogo
    ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
    With ActiveWindow.Selection.ShapeRange.TextFrame
        .MarginBottom = 0
        .MarginTop = 0
        .MarginLeft = 0
        .MarginRight = 0
        .HorizontalAnchor = msoAnchorCenter
        .VerticalAnchor = msoAnchorMiddle
    End With

    wkTxt = parAreaStatus
    wkCol = wkWhite
    wkColTxt = wkBlack

    If parAreaLogo = "Self-Assessment Score (%)" Then
        Select Case UCase(parAreaStatus)

            Case "x"
                wkCol = wkWhite
            Case "TBC"
                wkCol = wkRed
                wkColTxt = wkWhite
            Case "PLANNED"
                wkCol = wkYellow
            Case "DEPLOYED"
                wkCol = wkDeployedCol
                wkColTxt = wkWhite
            Case "PARTIAL"
                wkCol = wkPartialCol
            Case "MATURE"
                wkCol = wkMatureCol
            Case Else
                wkCol = wkMatureCol
        End Select
        wkTxt = UCase(parAreaStatus)
    Else
        Select Case UCase(parAreaStatus)
            Case "N/A"
                wkCol = wkWhite
                wkTxt = UCase(parAreaStatus)
            Case "TBC"
                wkCol = wkRed
                wkTxt = parAreaLogo
                wkColTxt = wkWhite
            Case "PLANNED"
                wkCol = wkYellow
                wkTxt = parAreaLogo
            Case Else
                If UCase(Left(wkTxt, 1)) = "P" Then
                    wkCol = wkYellow
                    wkTxt = LTrim(Mid(wkTxt, 2))
                Else
                    Select Case parAreaLogo
                        Case "SCI"
                            wkCol = wkColor_SCI
                            wkColTxt = wkWhite
                        Case "SCO"
                            wkCol = wkColor_SCO
                            wkColTxt = wkWhite
                        Case "FIN"
                            wkCol = wkColor_FIN
                        Case "BUY"
                            wkCol = wkColor_BUY
                            wkColTxt = wkWhite
                        Case "SPM"
                            wkCol = wkColor_SPM
                        Case "QFS"
                            wkCol = wkColor_QFS
                        Case "DMD"
                            wkCol = wkColor_DMD
                            wkColTxt = wkWhite
                        Case "SUP"
                            wkCol = wkColor_SUP
                            wkColTxt = wkWhite
                        Case "SEQ"
                            wkCol = wkColor_SEQ
                        Case "IPO"
                            wkCol = wkColor_IPO
                            wkColTxt = wkWhite
                        Case "SOP"
                            wkCol = wkColor_SOP
                        Case "OTH"
                            wkCol = wkColor_OTH
                    End Select
                End If
                wkMonth = Mid(wkTxt, 7, 2)
                If wkMonth = "00" Then
                    wkTxt = Mid(wkTxt, 1, 4)
                Else
                    wkTxt = Mid(wkTxt, 3, 2) & "/" & Mid(wkTxt, 7, 2)
                End If
        End Select
    End If

    ActiveWindow.Selection.ShapeRange.Fill.ForeColor.RGB = wkColTxt
    With ActiveWindow.Selection.TextRange
        .Text = wkTxt
        With .Font
            .Name = "Times New Roman"
            .Size = 12
            .Color = wkColTxt
        End With
    End With

End Sub

Sub CleanMap()

    Dim i As Integer
    Dim j As Integer

    For j = ActivePresentation.Slides.Count To 1 Step -1
        For i = ActivePresentation.Slides(j).Shapes.Count To 1 Step -1
            If (ActivePresentation.Slides(j).Shapes(i).Name Like "*_Board") _
                        Or (ActivePresentation.Slides(j).Shapes(i).Name Like "*_Line") Then
                ActivePresentation.Slides(j).Shapes(i).Delete
            End If
        Next i
    Next j

End Sub

Sub LocateIt()

    If ActiveWindow.Selection.Type = 0 Then
        MsgBox "No shape selected"
        Exit Sub
    End If

    With ActiveWindow.Selection.ShapeRange(1)
        MsgBox Int(.Left) & " - " & Int(.Top), vbInformation + vbOKOnly, .Name
    End With

End Sub

Sub NameIt()

    Dim sResponse As String

    If ActiveWindow.Selection.Type = 0 Then
        MsgBox "No shape selected"
        Exit Sub
    End If

    With ActiveWindow.Selection.ShapeRange(1)
        sResponse = InputBox("Rename this shape to ...", "Rename Shape", .Name)
        Select Case sResponse
            ' blank names not allowed
            Case Is = ""
                Exit Sub
            ' no change?
            Case Is = .Name
                Exit Sub
            Case Else
                On Error Resume Next
                .Name = sResponse
                If Err.Number <> 0 Then
                    MsgBox "Unable to rename this shape"
                End If
        End Select
    End With

End Sub

Sub SetToolBar()

    Dim wkToolBar As CommandBar
    Dim wkButton As CommandBarButton

    Set wkToolBar = CommandBars.Add(Name:="Map", Temporary:=True)
    With CommandBars("Map")
        .Visible = True
        .Left = 100
        .Top = 150
    End With

    Set wkButton = wkToolBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
    With wkButton
        .Caption = "GenerateMap"
        .OnAction = "GenerateMap"
        .Style = msoButtonCaption
    End With

    Set wkButton = wkToolBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
    With wkButton
        .Caption = "UpdateMap"
        .OnAction = "UpdateMap"
        .Style = msoButtonCaption
    End With

    Set wkButton = wkToolBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
    With wkButton
        .Caption = "CleanMap"
        .OnAction = "CleanMap"
        .Style = msoButtonCaption
    End With

    Set wkButton = wkToolBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
    With wkButton
        .Caption = "LocateIt"
        .OnAction = "LocateIt"
        .Style = msoButtonCaption
    End With

    Set wkButton = wkToolBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
    With wkButton
        .Caption = "NameIt"
        .OnAction = "NameIt"
        .Style = msoButtonCaption
    End With

    SlideShowWindows(Index:=1).View.Exit
    ActiveWindow.View.GotoSlide Index:=1

End Sub

excel vba powerpoint
person SuGo    schedule 17.01.2013    source источник
comment
Добро пожаловать в Переполнение стека. Слишком много кода, пожалуйста, сократите его немного. Также см. часто задаваемые вопросы и Как Спросить, если вы еще этого не сделали. Удачи!   -  person Jeremy Thompson    schedule 17.01.2013

Ответы (1)


arrow_upward
1
arrow_downward

Я понял это. Это было действительно больше, чем просто переименование некоторых переменных и т. д. Старая тема; этот проект тоже больше не работает. Спасибо всем.

Кроме того, извините за размещение его неправильно, чтобы начать. Это была моя первая тема.

person SuGo    schedule 15.02.2013