stringQYe拜客生活常识网

" .Font.Name = "宋体" .Font.Bold = True .Font.Size = 9 .Top = 0 End With End Sub Sub Chart_FillData(MyChart As ChartObject, SerieName As String, Xrng As Range, Yrng As Range) With MyChart.chart Dim ns Set ns = .SeriesCollection.NewSeries ns.Values = Xrng If Not Yrng Is Nothing Then ns.XValues = Yrng ns.Name = SerieName End With End Sub Sub Chart_FinalStyle(MyChart As ChartObject) With MyChart.chart ' .ChartTitle.Left = (myChart.Chart.ChartArea.Width / 2) - (myChart.Chart.ChartTitle.Width / 2) End With End Sub Sub Chart_Axes(MyChart As ChartObject) MyChart.chart.Axes(xlValue).HasMajorGridlines = True With MyChart.chart.Axes(xlValue).MajorGridlines.Border .ColorIndex = 15 .Weight = xlHairline .LineStyle = xlDot End With End Sub Sub Chart_SeriesPoint(MyChart As ChartObject, S1) Dim ms As SeriesCollection MyChart.Activate ActiveChart.SeriesCollection(1).Points(S1).Select With Selection.Format.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorAccent2 .ForeColor.TintAndShade = 0 ' .ForeColor.Brightness = 0 '透明度设置 0.400000006=40% .Transparency = 0 .Solid End With End Sub Sub Chart_Transmit(ChartName As String, Gsht As Worksheet) Dim C As ChartObject Set C = Gsht.ChartObjects(ChartName) With Gsht.Shapes(ChartName) .Fill.ForeColor.RGB = RGB(63, 74, 92) ' .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' .Line.ForeColor.RGB = RGB(255, 0, 0) ' .Line.ForeColor.ObjectThemeColor = msoThemeColorBackground1 End With With C.chart.ChartArea .Font.ColorIndex = 2 .Border.ColorIndex = 2 End With C.CopyPicture Appearance:=xlPrinter, Format:=xlPicture ' C.Chart.Export C.Name & ".JPG" '导出到文件路径文件夹 End Sub Sub ChartToPicture(ChartName As String, Gsht As Worksheet, Grng As Range) Dim C As ChartObject Gsht.Select Set C = Gsht.ChartObjects(ChartName) C.Copy Grng.Select Gsht.PasteSpecial Format:="图片(JPEG)" Call ShapeCheck("P" & ChartName, Gsht) Selection.Name = "P" & ChartName C.Delete End Sub Sub ChartCheck(ChartName As String, Gsht As Worksheet) Dim R1, zstr Dim C As ChartObject R1 = Gsht.ChartObjects.Count If R1 > 0 Then For Each C In Gsht.ChartObjects zstr = C.Name If zstr = ChartName Then C.Delete Next End If End Sub Sub ShapeCheck(ShapeName As String, Gsht As Worksheet) Dim R1, zstr Dim s As Shape R1 = Gsht.Shapes.Count If R1 > 0 Then For Each s In Gsht.Shapes zstr = s.Name If zstr = ShapeName Then s.Delete Next End If End Sub 'Sub Chart_XY_Axes() '第六部分：设置XY轴 'myChart.Chart.Axes(xlCategory, xlPrimary).HasTitle = True 'XlCategory是X轴 'mychart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "X轴标题" 'With myChart.Chart.Axes(xlCategory, xlPrimary) ' .CrossesAt = 0 ' .TickLabelSpacing = 1 ' .TickMarkSpacing = 1 ' .AxisBetweenCategories = True ' .ReversePlotOrder = False 'End With 'myChart.Chart.Axes(xlValue, xlPrimary).HasTitle = True 'xlValue是Y轴 'myChart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "项目数" ' 'myChart.Chart.SetElement (msoElementPrimaryValueAxisTitleHorizontal) 'With myChart.Chart.Axes(xlValue, xlPrimary) ' .MinimumScale = 0 '最小值 ' .MaximumScale = 10 '最大值 ' .MajorUnit = 2 '主要间距 ' .MinorUnit = xlAutomatic '次要间距 ' .CrossesAt = 0 '坐标轴的交叉点 ' .ReversePlotOrder = False ' .ScaleType = xlLinear 'End With '第八部分：调整对比point的颜色 'Dim ms As SeriesCollection 'Set ms = myChart.Chart.SeriesCollection(1).points(1) 'End Sub

模块9：实现自动分级分组

Option Explicit

Sub group_by()

Application.ScreenUpdating = False

Dim sh_0 As Worksheet
Dim sh_1 As Worksheet
    
    Call loading_data
    
    Set sh_0 = ThisWorkbook.Sheets("res")
    Set sh_1 = ThisWorkbook.Sheets("structure")
    
    
    With sh_1
        With .Cells
            .Clear
            .Font.Size = 9
            .VerticalAlignment = xlCenter
            .RowHeight = 16.25
        End With
        .Select
        With .Rows(1)
            .Font.Bold = True
            .RowHeight = 22.75
        End With
        
        sh_0.Range("a:e").Copy
        .Range("a1").PasteSpecial (xlPasteValues)
    End With
    
    Call melt
    Call group
Application.ScreenUpdating = True

End Sub

Sub loading_data()

Dim sql$
Dim spath$
Dim arr
Dim sht As Worksheet

    Set sht = ThisWorkbook.Sheets("res")
    spath = ThisWorkbook.FullName
    sql = "select tb_sort,表名,业务,按业务分类,指标数 from("
    sql = sql + "Select tb_sort,表名,业务,按业务分类,count(1) as 指标数 ,b_sort,bc_sort from [indicator $] "
    sql = sql + "group by tb_sort,表名,业务,按业务分类,b_sort,bc_sort "
    sql = sql + "order by tb_sort ,b_sort,bc_sort) "

    arr = Extract(sql, spath)
    With sht
        .Cells.Clear
        .Range("A1").Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr
    End With

End Sub


Sub melt()

Dim nr, nc
Dim sh As Worksheet

    Set sh = ThisWorkbook.Sheets("structure")
    nc = sh.UsedRange.Columns.Count
    sh.Cells.ClearOutline
    sh.Range("a1:e1").Interior.Color = RGB(255, 217, 102)
    
Dim i, j, k
Dim ini_str, tmp_str
Dim tmp_c, tmp_end
Dim tmp_array

        tmp_array = Array(1, 3)
    
'    tmp_array = Array(4)
    j = LBound(tmp_array)
    
    Do While j