2018年10月1日 星期一

更改資料標籤工具

一直在網路上尋找,變更EXCEL圖表標籤的工具。
其巨集內容如下。存放於部落格備用,該工具可以省去不少人工修改操作。
簡體內容變亂碼,重新修改成看的懂內容。

Option Explicit

Sub DataLableChange()
Dim I%, LblCnt%, iRows%, iCols%
Dim shnm$, sn$, Msg$
Dim rngLbl As Range

Select Case TypeName(Selection)
Case "DataLabel"
    sn = Selection.Parent.Parent.Name
Case "DataLabels"
    sn = Selection.Parent.Name
Case "Series"
    sn = Selection.Name
Case Else
    MsgBox "請先選擇要變更的標籤,再執行此巨集", vbOKOnly, "尚未選擇要變更的資料標籤"
    Exit Sub
End Select

Err.Clear: On Error Resume Next
Set rngLbl = Application.InputBox("請輸入標籤所引用的區域,可以用滑鼠選擇區域", "標籤的引用區域", , , , , , 8)
Err.Clear: On Error GoTo 0
If rngLbl Is Nothing Then Exit Sub

iRows = rngLbl.Rows.Count
iCols = rngLbl.Columns.Count
LblCnt = ActiveChart.SeriesCollection(sn).Points.Count
shnm = rngLbl.Parent.Name
If Application.Max(iRows, iCols) < ActiveChart.SeriesCollection(sn).Points.Count Then
    Msg = MsgBox("所引用的區域與標籤區域數量不符" & Chr(10) & "選""Yes""依選擇區域更改" & Chr(10) & "選""No""重新選擇區域", vbYesNo, "警告")
    Select Case Msg
    Case vbYes
        LblCnt = Application.Max(iRows, iCols)
    Case vbNo
        Exit Sub
    End Select
End If

Application.ScreenUpdating = False
On Error Resume Next
With ActiveChart.SeriesCollection(sn)
    For I = 1 To LblCnt
        Err.Clear
        .Points(I).ApplyDataLabels
        If Err.Number = 0 Then
            If iRows > iCols Then
                .Points(I).DataLabel.Text = "='" & shnm & "'!" & rngLbl.Cells(I, 1).Resize(1, iCols).Address(ReferenceStyle:=xlR1C1)
            Else
                .Points(I).DataLabel.Text = "='" & shnm & "'!" & rngLbl.Cells(1, I).Resize(iRows, 1).Address(ReferenceStyle:=xlR1C1)
            End If
        End If
    Next
End With
Err.Clear: On Error GoTo 0
Application.ScreenUpdating = True
End Sub

沒有留言:

張貼留言