求VBA循环执行

电脑专家俱乐部

图表.rar (8.67 KB, 下载次数: 22)

2012-8-14 13:13 上传

点击文件名下载附件

怎么往下执行，直到空的停止。一行做出一个图表。

该贴已经同步到 电脑专家俱乐部的微博

余余1982

循环可以~但是图表全部重叠在一起。需手动托拉开！期待高手优化~

电脑专家俱乐部

余余1982 发表于 2012-8-14 14:32
循环可以~但是图表全部重叠在一起。需手动托拉开！期待高手优化~

往下在增加好像就用不了，最好是往下增加和加列都能用

jiangwh15

试试看

Sub Macro1()
    Dim a As ChartObject
    Dim FinalRow As Long
    Dim i As Long
   
    FinalRow = ActiveSheet.Range("a" & Rows.Count).End(3).Row
   
    If FinalRow <= 1 Then
    Exit Sub
    End If
   
    For i = 2 To FinalRow
        Set a = ActiveSheet.ChartObjects.Add(100, 30 + (i - 2) * 200, 320, 200)
        a.Chart.SetSourceData Source:=ActiveSheet.Range("$A$" & i & ":$H$" & i)
        a.Chart.ChartType = xlLine
        a.Chart.SeriesCollection(1).XValues = ActiveSheet.Range("B1:H1")
        Set a = Nothing
    Next
End Sub

jiangwh15

来个通用的程序

Sub AddChart()
    Dim a As ChartObject
    Dim FinalRow As Long
    Dim FinalCol As Integer
    Dim i As Long
   
    FinalRow = ActiveSheet.Range("a" & Rows.Count).End(3).Row
    FinalCol = ActiveSheet.Cells(1, Columns.Count).End(1).Column
   
    If FinalRow <= 1 Then
        MsgBox "没有数据！"
        Exit Sub
    End If
   
   
    With ActiveSheet
        .ChartObjects.Delete
        For i = 2 To FinalRow
            Set a = .ChartObjects.Add(100, 30 + (i - 2) * 200, 320, 200)
            a.Chart.SetSourceData Source:=.Range(.Cells(i, 1), .Cells(i, FinalCol))
            a.Chart.ChartType = xlLine
            a.Chart.SeriesCollection(1).XValues = .Range("B1:H1")
            Set a = Nothing
        Next
    End With
End Sub

doitbest

Sub Macro1()
Dim i, c
c = [a1].End(2).Column
For i = 2 To [a65536].End(3).Row
    ActiveSheet.Shapes.AddChart.Select
    Selection.Left = Cells(i, c + 1).Left
    Selection.Top = Cells(i, 1).Top
    ActiveChart.SetSourceData Source:=Range(Sheets(1).Cells(i, 1), Sheets(1).Cells(i, c)) 'Range(Range(Sheets(1).Cells(i, 1), Sheets(1).Cells(i, 8)).Address)
    ActiveChart.ChartType = xlLine
    ActiveChart.Axes(xlCategory).Select
    ActiveChart.SeriesCollection(1).XValues = "='" & ActiveSheet.Name & "'!" & [b1].Resize(1, c - 1).Address
Next i
End Sub

jiangwh15

电脑专家俱乐部 发表于 2012-8-16 11:40
能不能在把添加数据标签加进去。怎么改啊

希望对你有用，呵呵。
Sub AddChrt()
    Dim a As ChartObject
    Dim FinalRow As Long
    Dim FinalCol As Integer
    Dim i As Long
   
    FinalRow = ActiveSheet.Range("a" & Rows.Count).End(3).Row
    FinalCol = ActiveSheet.Cells(1, Columns.Count).End(1).Column
   
    If FinalRow <= 1 Or FinalCol <= 1 Then
        MsgBox "请输入数据，谢谢！"
        Exit Sub
    End If
   
   
    With ActiveSheet
        .ChartObjects.Delete
        For i = 2 To FinalRow
            Set a = .ChartObjects.Add(100, 30 + (i - 2) * 200, 320, 200)
            a.Chart.SetSourceData Source:=.Range(.Cells(i, 1), .Cells(i, FinalCol))
            a.Chart.ChartType = xlLine
            a.Chart.HasLegend = False
            a.Chart.SeriesCollection(1).XValues = .Range(.Cells(1, 2), .Cells(1, FinalCol))
            a.Chart.SeriesCollection(1).ApplyDataLabels ShowValue:=True
            Set a = Nothing
        Next
    End With
End Sub

电脑专家俱乐部

jiangwh15 发表于 2012-8-14 15:14
试试看

Sub Macro1()

这个可以，谢谢

电脑专家俱乐部

高人真多，{:soso_e130:}非常感谢大家的回答

电脑专家俱乐部

jiangwh15 发表于 2012-8-14 15:14
试试看

Sub Macro1()

能不能在把添加数据标签加进去。怎么改啊