gpt4 book ai didi

excel - VB/A : Streaming data from Excel to PowerPoint

转载 作者:行者123 更新时间:2023-12-04 20:46:29 26 4
gpt4 key购买 nike

此图显示了最终产品的外观:
picture

  • 有一个带有行和列的 Excel 电子表格。行是国家。列是数据。但是,我只对 excel 电子表格的一列感兴趣。
  • 如图所示,一个箭头指向国家,然后用“1”创建该表(1 只是一个测试,但显然它们是不同的数字或 Excel 电子表格中的任何数字)。
  • 我遇到以下问题:

    一个。我想创建一个比例:如果列中的整数> 80,它将是绿色背景。如果它在 65-79 之间,那么它将是橙色的。如果低于 65,则为红色。正如你在我展示的图片中看到的那样, table 的所有背景都是绿色的。我什至不知道它为什么是绿色的,也不知道它是如何变绿的。所以这是一个问题。
  • 某些国家工作不正常。没有形成箭头,表格只是随机出现在 map 上的随机位置。

  • 这是我的代码:

    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 - VB/A : Streaming data from Excel to PowerPoint,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/14371661/

    26 4 0
    Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
    广告合作:1813099741@qq.com 6ren.com