[已解决]VBA自动绘制图表高手请进，遇到瓶颈了！

zte10157616

说明：

初始数据源为“地市+厂家+KPI” sheet；

然后把该sheet中  每个城市对应的数据（红色表头黑色加粗子）和日期填入后边各个对应的sheets，然后再各个sheets内自动绘制图标！且自动根据各sheet行数绘制附件各sheet中样式的图标！多谢！

附件如下：
ZTE_PM-KPI_MakeTool_V1.1-旧版.zip (29.92 KB, 下载次数: 7)

2014-5-24 18:29 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-5-25 22:12

1. Sub demo()
   
2.     Const adUseClient = 3
   
3.     Const adModeRead = 1
   
4.     Dim AdoConn As Object, AdoRst As Object
   
5.     Dim StrConn$, strFullName$
   
6.     Dim i As Integer
   
7.     Dim strSql$, strSql2$, arr1, arr2
   
8.    
   
9.     On Error GoTo ErrorHandler
   
10.    
    
11.     strSql = "select  年份,时间段,城市,机型,"
    
12.     strSql2 = " from [地市+厂家+KPI$a2:o]"
    
13.     arr1 = Array("无线接通率", "无线掉线率", "切换成功率", "无线利用率", "吞吐量")
    
14.     arr2 = Array("无线接通率", "无线掉线率", "切换成功率", "无线利用率", "总吞吐量")
    
15.     strFullName = ThisWorkbook.FullName
    
16.    
    
17.     Set AdoConn = CreateObject("ADODB.Connection")
    
18.     Select Case Application.Version
    
19.         Case "14.0", "15.0", "12.0", "14.0"
    
20.             StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
    
21.                       strFullName & "';Extended Properties='Excel 12.0;HDR=YES;imex=1';"
    
22.         Case Else
    
23.             StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
24.                       "Data Source='" & strFullName & "';Extended Properties='Excel 8.0;HDR=YES;imex=1';"
    
25.     End Select
    
26. 
    
27.     With AdoConn
    
28.         .CursorLocation = adUseClient
    
29.         .Mode = adModeRead
    
30.         .ConnectionString = StrConn
    
31.         .Open
    
32.     End With
    
33. 
    
34.     For i = LBound(arr1) To UBound(arr1)
    
35.         Set AdoRst = AdoConn.Execute(strSql & arr1(i) & strSql2)
    
36.         With Worksheets(arr2(i))
    
37.             .Range("a2").CopyFromRecordset AdoRst
    
38.             With .ChartObjects(1).Chart
    
39.                 .SeriesCollection(1).XValues = Worksheets(arr2(i)).Range("a2:d" & 2 + AdoRst.RecordCount)
    
40.                 .SeriesCollection(1).Values = Worksheets(arr2(i)).Range("E2:E" & 2 + AdoRst.RecordCount)
    
41.                 .Refresh
    
42.             End With
    
43.         End With
    
44.     Next
    
45.     Set AdoRst = Nothing
    
46.     AdoConn.Close
    
47.     Set AdoConn = Nothing
    
48.     MsgBox "完成"
    
49.     Exit Sub
    
50. ErrorHandler:
    
51.     Dim strErr$
    
52.     strErr = "出现异常！" & vbCr
    
53.     strErr = strErr & "错误代码：" & Err.Number & vbCr
    
54.     strErr = strErr & "错误描述：" & Err.Description & vbCr
    
55.     strErr = strErr & "错误来源：" & Err.Source
    
56.     MsgBox strErr, vbCritical + vbOKOnly
    
57. End Sub

复制代码

没有错，忘了刷新，你的数据表因为有使用的空行，所以一直是11行。

跳转到最佳答案楼层

zte10157616

附件中只列了一个城市的汇总数据，请考虑多变的行……

zte10157616

求助大侠帮搞定啊……

zte10157616

坐等高手……

zte10157616

求帮助！！！

hwc2ycy

1. Sub demo()
   
2. 
   
3.     Dim AdoConn As Object
   
4.     Dim AdoRst As Object
   
5.     Const adUseClient = 3
   
6.     Const adModeRead = 1
   
7. 
   
8. 
   
9.     Dim i As Integer
   
10.     Dim strSql$, strSql2$, arr1, arr2
    
11.     On Error GoTo ErrorHandler
    
12.     strSql = "select  年份,时间段,城市,机型,"
    
13.     strSql2 = " from [地市+厂家+KPI$a2:o]"
    
14.     arr1 = Array("无线接通率", "无线掉线率", "切换成功率", "无线利用率", "吞吐量")
    
15.     arr2 = Array("无线接通率", "无线掉线率", "切换成功率", "无线利用率", "总吞吐量")
    
16. 
    
17.     Dim StrConn$, strFullName$
    
18.     strFullName = ThisWorkbook.FullName
    
19. 
    
20.     On Error GoTo ErrorHandler
    
21.     Set AdoConn = CreateObject("ADODB.Connection")
    
22. 
    
23. 
    
24.     Select Case Application.Version
    
25.         Case "14.0", "15.0", "12.0", "14.0"
    
26.             StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
    
27.                       strFullName & "';Extended Properties='Excel 12.0;HDR=YES;imex=1';"
    
28.         Case Else
    
29.             StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
30.                       "Data Source='" & strFullName & "';Extended Properties='Excel 8.0;HDR=YES;imex=1';"
    
31.     End Select
    
32. 
    
33.     With AdoConn
    
34.         .CursorLocation = adUseClient
    
35.         .Mode = adModeRead
    
36.         .ConnectionString = StrConn
    
37.         .Open
    
38.     End With
    
39. 
    
40.     Debug.Print strSql
    
41.     For i = LBound(arr1) To UBound(arr1)
    
42.         Set AdoRst = AdoConn.Execute(strSql & arr1(i) & strSql2)
    
43.         With Worksheets(arr2(i))
    
44.             .Range("a2").CopyFromRecordset AdoRst
    
45.             With .ChartObjects(1).Chart
    
46.                 .SeriesCollection(1).XValues = "=" & arr1(i) & "!$A$2:$D$" & 2 + AdoRst.RecordCount
    
47.                 .SeriesCollection(1).Values = "=" & arr1(i) & "!$E$2:$E$" & 2 + AdoRst.RecordCount
    
48.             End With
    
49.         End With
    
50.     Next
    
51.     Set AdoRst = Nothing
    
52.     AdoConn.Close
    
53.     Set AdoConn = Nothing
    
54.     MsgBox "完成"
    
55.     Exit Sub
    
56. ErrorHandler:
    
57.     Dim strErr$
    
58.     strErr = "出现异常！" & vbCr
    
59.     strErr = strErr & "错误代码：" & Err.Number & vbCr
    
60.     strErr = strErr & "错误描述：" & Err.Description & vbCr
    
61.     strErr = strErr & "错误来源：" & Err.Source
    
62.     MsgBox strErr, vbCritical + vbOKOnly
    
63. End Sub

复制代码

图表的没弄好，晚上回来再解决。

zte10157616

hwc2ycy 发表于 2014-5-25 06:26
图表的没弄好，晚上回来再解决。

大侠啥情况这是？代码看不懂啊，不是常规代码啊！

hwc2ycy

1. Sub demo()
   
2.     Const adUseClient = 3
   
3.     Const adModeRead = 1
   
4.     Dim AdoConn As Object, AdoRst As Object
   
5.     Dim StrConn$, strFullName$
   
6.     Dim i As Integer
   
7.     Dim strSql$, strSql2$, arr1, arr2
   
8.    
   
9.     On Error GoTo ErrorHandler
   
10.    
    
11.     strSql = "select  年份,时间段,城市,机型,"
    
12.     strSql2 = " from [地市+厂家+KPI$a2:o]"
    
13.     arr1 = Array("无线接通率", "无线掉线率", "切换成功率", "无线利用率", "吞吐量")
    
14.     arr2 = Array("无线接通率", "无线掉线率", "切换成功率", "无线利用率", "总吞吐量")
    
15.     strFullName = ThisWorkbook.FullName
    
16.    
    
17.     Set AdoConn = CreateObject("ADODB.Connection")
    
18.     Select Case Application.Version
    
19.         Case "14.0", "15.0", "12.0", "14.0"
    
20.             StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & _
    
21.                       strFullName & "';Extended Properties='Excel 12.0;HDR=YES;imex=1';"
    
22.         Case Else
    
23.             StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
24.                       "Data Source='" & strFullName & "';Extended Properties='Excel 8.0;HDR=YES;imex=1';"
    
25.     End Select
    
26. 
    
27.     With AdoConn
    
28.         .CursorLocation = adUseClient
    
29.         .Mode = adModeRead
    
30.         .ConnectionString = StrConn
    
31.         .Open
    
32.     End With
    
33. 
    
34.     For i = LBound(arr1) To UBound(arr1)
    
35.         Set AdoRst = AdoConn.Execute(strSql & arr1(i) & strSql2)
    
36.         With Worksheets(arr2(i))
    
37.             .Range("a2").CopyFromRecordset AdoRst
    
38.             With .ChartObjects(1).Chart
    
39.                 .SeriesCollection(1).XValues = Worksheets(arr2(i)).Range("a2:d" & 2 + AdoRst.RecordCount)
    
40.                 .SeriesCollection(1).Values = Worksheets(arr2(i)).Range("E2:E" & 2 + AdoRst.RecordCount)
    
41.                 .Refresh
    
42.             End With
    
43.         End With
    
44.     Next
    
45.     Set AdoRst = Nothing
    
46.     AdoConn.Close
    
47.     Set AdoConn = Nothing
    
48.     MsgBox "完成"
    
49.     Exit Sub
    
50. ErrorHandler:
    
51.     Dim strErr$
    
52.     strErr = "出现异常！" & vbCr
    
53.     strErr = strErr & "错误代码：" & Err.Number & vbCr
    
54.     strErr = strErr & "错误描述：" & Err.Description & vbCr
    
55.     strErr = strErr & "错误来源：" & Err.Source
    
56.     MsgBox strErr, vbCritical + vbOKOnly
    
57. End Sub

复制代码

没有错，忘了刷新，你的数据表因为有使用的空行，所以一直是11行。

hwc2ycy

ZTE_PM-KPI_MakeTool_V1.1-旧版.rar (51.74 KB, 下载次数: 17)

2014-5-25 22:22 上传

点击文件名下载附件

hwc2ycy

zte10157616 发表于 2014-5-25 17:13
大侠啥情况这是？代码看不懂啊，不是常规代码啊！

懒得用数组来处理，偷个懒取巧。