VBA创建链接并实现图表工作表按钮返回

Option Explicit

'输出
Sub export()
    Dim sht As Worksheet, sql As String, sht1 As Worksheet, i, shtname, rng
    
    Set sht = ThisWorkbook.Worksheets("HZ")
    sql = "SELECT DISTINCT YF,SP,'' TB FROM CG order by yf,sp"
    exportdata sht, sql
    
    For i = 2 To sht.UsedRange.Rows.Count
        shtname = sht.Cells(i, 1) & "_" & sht.Cells(i, 2)
        Set sht1 = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        sht1.Name = shtname
        sql = "exec getdata '" & sht.Cells(i, 1) & "','" & sht.Cells(i, 2) & "'"
        exportdata sht1, sql
        Set sht1 = Nothing
        
    Next
    
    
    For i = 2 To sht.UsedRange.Rows.Count
        shtname = sht.Cells(i, 1) & "_" & sht.Cells(i, 2)
        
        sht.Activate
        Set rng = sht.Cells(i, 3)
        rng.Hyperlinks.Add anchor:=rng, Address:="", SubAddress:="HZ!A1", TextToDisplay:="图表"
        Set rng = Nothing
        
        CreateChart (shtname)
        ThisWorkbook.Worksheets(shtname).Visible = False
    Next
    
    sht.Activate
    Set sht = Nothing

End Sub

' openrecordset 输出工作表
Sub exportdata(sht As Worksheet, sql As String)
    Dim conn, rs, i
    sht.Cells.Clear
    
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("Adodb.Recordset")
    conn.Open "Provider=sqloledb;server=127.0.0.1,1433\sqlexpress;database=amain;Integrated Security=SSPI;Persist Security Info =False;"
    rs.Open sql, conn
    
    For i = 0 To rs.Fields.Count - 1
        sht.Cells(1, i + 1) = rs(i).Name
    Next
    
    sht.Range("a2").CopyFromRecordset rs
    
    conn.Close
    
    Set rs = Nothing
    Set conn = Nothing
    'Set sht = Nothing
End Sub

'创建图表
Sub CreateChart(shtname)
    
    Dim sht As Worksheet, max, min
    Set sht = ThisWorkbook.Worksheets(shtname)
    sht.Activate
    
    max = Excel.Application.WorksheetFunction.max(sht.Range("B2:E" & sht.UsedRange.Rows.Count))
    min = Excel.Application.WorksheetFunction.min(sht.Range("B2:E" & sht.UsedRange.Rows.Count))
    
    sht.Shapes.AddChart2(332, xlLineMarkers).Select
    With ActiveChart
        .SetSourceData Source:=sht.UsedRange
        .ChartStyle = 236
        .ChartTitle.Text = Mid(shtname, 1, 4) & "年" & CInt(Mid(shtname, 5, 2)) & "月 " & Split(shtname, "_")(1)
        .Axes(xlValue).MinimumScale = Round(min - (max - min) * 0.4, 2)
        .Axes(xlValue).MaximumScale = Round(max + (max - min) * 0.1, 2)
    End With
    
    With ActiveChart.ChartTitle.Format.TextFrame2.TextRange.Font
    .NameComplexScript = "微软雅黑"
    .NameFarEast = "微软雅黑"
    .Name = "微软雅黑"
    .Size = 22
    End With
 
    sht.ChartObjects(1).Activate
    ActiveChart.Location Where:=xlLocationAsNewSheet
    ActiveSheet.Name = "c_" & shtname
    
    AddButton "c_" & shtname
    
    Set sht = Nothing
End Sub

'添加返回按钮
Private Sub AddButton(chartname)
    
    Dim char As Chart
    Set char = ThisWorkbook.Sheets(chartname)
    
    Dim sha As Shape
    Set sha = char.Shapes.AddFormControl(Type:=xlButtonControl, Left:=20, Top:=20, Width:=50, Height:=20)
        
    With sha
        With .TextFrame.Characters
            .Text = "返回"
        End With
        .OnAction = "FanHui"
    End With
        
    Set sha = Nothing
    Set char = Nothing
End Sub

'清除sheet
Private Sub deleAllSheets()
    Dim sht
    Excel.Application.DisplayAlerts = False
    For Each sht In ThisWorkbook.Sheets
        If sht.Name <> "HZ" Then sht.Delete
    Next
    ThisWorkbook.Worksheets("HZ").Cells.Clear
    Excel.Application.DisplayAlerts = True
End Sub

'返回事件
Sub FanHui()
    ThisWorkbook.Worksheets("HZ").Activate
End Sub

Option Explicit

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim rng As Range, shtname
    Set rng = Target.Range

    shtname = "c_" & rng.Offset(0, -2).Value & "_" & rng.Offset(0, -1).Value
    ThisWorkbook.Sheets(shtname).Activate
    Set rng = Nothing
End Sub