给Chart对象添加新标签

Option Explicit

'Add Null To ChartDataSourceSheet
Sub testQuery()
    
    Call ExcelQuery("select * from [Sheet3$] where 标签 like '%MSRP%'", ActiveCell)

End Sub
Sub testLabel()
    Dim a, b
'    a = ToArr(Array("徐州市", "宿迁市", "宿迁市", "淮安市", "镇江市"))
'    Call UpdateChartDataLabel(ActiveChart, a, 2)
    
'    a = ToArr(Array(Null, Null, "宿迁市", "淮安市", "镇江市"))
'    b = ToArr(Array(Null, Null, 45000, 48500, 53000))
    
    a = ToD2Arr(ActiveSheet.[f2].Resize(4, 1))
    b = ToD2Arr(ActiveSheet.[g2].Resize(4, 1))
    'Call UpdateChartDataLabel(ActiveChart, a)
    Call UpdateChartDataLabel2(ActiveChart, a, b)
End Sub

Public Sub UpdateChartDataLabel(Cht As Object, LabelVal)
    Dim a&, i&, j&, iRows&, iCols&, ArrVal As Variant
    Application.ScreenUpdating = False
    On Error Resume Next
    ArrVal = ToD2Arr(LabelVal)
    For i = 1 To Cht.SeriesCollection.Count
        With Cht.SeriesCollection(i)
            .HasDataLabels = False
            For j = 1 To .Points.Count
                .Points(j).ApplyDataLabels
                .DataLabel.ShowValue = True
                .DataLabel.AutoText = True
                .Points(j).DataLabel.Text = ArrVal(i, j - 1 + LBound(ArrVal))
                With .DataLabels
                    .Font.Size = 10
                    .Font.Color = RGB(0, 0, 0)
                    .Font.name = "微软雅黑"
                    .Font.Bold = False
                    .Position = xlLabelPositionAbove
                End With
            Next j
        End With
    Next i
    Application.ScreenUpdating = False
End Sub

Public Sub UpdateChartDataLabel2(Cht As Object, LabelVal, DiscountVal)
    Dim a&, i&, j&, iRows&, iCols&, ArrVal As Variant, ArrVal2 As Variant
    Application.ScreenUpdating = False
    On Error Resume Next
    ArrVal = ToD2Arr(LabelVal)
    ArrVal2 = ToD2Arr(DiscountVal)
    For i = 1 To Cht.SeriesCollection.Count
        With Cht.SeriesCollection(i)
            .HasDataLabels = False
            For j = 1 To .Points.Count
                With .Points(j)
                    .ApplyDataLabels
                    .DataLabel.ShowValue = True
                    .DataLabel.AutoText = True
                    .DataLabel.Text = ArrVal(i, j - 1 + LBound(ArrVal, 1)) _
                                            & "，" _
                                            & Format(ArrVal2(i, j - 1 + LBound(ArrVal2, 1)), "###,#0;[红色]-###,#0;0")
                End With
                With .DataLabels
                    .Font.Size = 8
                    .Font.Color = RGB(0, 0, 0)
                    .Font.name = "微软雅黑"
                    .Font.name = "Arial"
                    .Font.Bold = False
                    .Position = xlLabelPositionAbove
                End With
            Next j
        End With
    Next i
    Application.ScreenUpdating = False
End Sub

Public Sub ExcelQuery(SqlText$, Out)
    Dim FilePath$, StrConn$, Conn As New ADODB.Connection, Rs As New ADODB.Recordset
    FilePath = ThisWorkbook.FullName
    StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" + FilePath + "; Extended Properties='Excel 12.0;HDR=Yes;IMEX=2'; Persist Security Info=False"
    Application.ScreenUpdating = False
    On Error Resume Next
    If CBool(Conn.State And adStateOpen) Then
        Conn.Close
    End If
    
    Conn.Open StrConn
    Conn.CommandTimeout = 0
    If Conn.State = adStateOpen Then
        Application.StatusBar = "成功连接数据库"
    Else
        MsgBox "无法打开数据库"
    End If
    
    Rs.Open SqlText, Conn, adOpenDynamic, adLockBatchOptimistic, adCmdText
    
    Dim i&, RsCount&, FieldCount&, arrTitle, arrRsFieldName
    On Error Resume Next
    RsCount = Rs.RecordCount
    FieldCount = Rs.Fields.Count
    ReDim arrTitle(0 To FieldCount - 1)
    For i = 0 To UBound(arrTitle)
        arrTitle(i) = Rs.Fields(i).name
    Next i
    arrRsFieldName = arrTitle
    
    If TypeName(Out) = "Range" Then
        With Out.Cells(1, 1)
            .CurrentRegion.ClearContents
            .Resize(1, FieldCount).Value = arrRsFieldName
            .Offset(1).CopyFromRecordset Rs
        End With
    Else
        Out = Application.WorksheetFunction.Transpose(Rs.GetRows)
    End If
    Application.ScreenUpdating = False
End Sub

Function OutQuery(SqlText$)
    Dim Out

    Call ExcelQuery(SqlText$, Out)
    OutQuery = Out
    
End Function