kkelk
2010/06/12, 01:30
با سلام ب دوستان عزیز
شاید تا به حال به فکر افتاده باشید که در یک سل نمودار مربوط به چندین سل مجاور را داشته باشید.
این امکان در اکسل 2007 وجود داره ولی در 2003 باید از طریق نوشتن کد انجام بگیره و یا بصورت add ins ساخته شده و استفاده بشه.
من این کد رو دانلود کردم و برای شما هم میگذارم امیدوارم که مفید باشد.
Function LineChart(Points As Range, Color As Long) As String
Const cMargin = 2
Dim rng As Range, arr() As Variant, i As Long, j As Long, k As Long
Dim dblMin As Double, dblMax As Double, shp As Shape
Set rng = Application.Caller
ShapeDelete rng
For i = 1 To Points.Count
If j = 0 Then
j = i
ElseIf Points(, j) > Points(, i) Then
j = i
End If
If k = 0 Then
k = i
ElseIf Points(, k) < Points(, i) Then
k = i
End If
Next
dblMin = Points(, j)
dblMax = Points(, k)
With rng.Worksheet.Shapes
For i = 0 To Points.Count - 2
Set shp = .AddLine( _
cMargin + rng.Left + (i * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
cMargin + rng.Top + (dblMax - Points(, i + 1)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin), _
cMargin + rng.Left + ((i + 1) * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
cMargin + rng.Top + (dblMax - Points(, i + 2)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin))
On Error Resume Next
j = 0: j = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(j)
arr(j) = shp.Name
Next
With rng.Worksheet.Shapes.Range(arr)
.Group
If Color > 0 Then .Line.ForeColor.RGB = Color Else .Line.ForeColor.SchemeColor = -Color
End With
End With
LineChart = ""
End Function
Sub ShapeDelete(rngSelect As Range)
Dim rng As Range, shp As Shape, blnDelete As Boolean
For Each shp In rngSelect.Worksheet.Shapes
blnDelete = False
Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
If Not rng Is Nothing Then
If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
End If
If blnDelete Then shp.Delete
Next
End Sub
[attachment=54]
شاید تا به حال به فکر افتاده باشید که در یک سل نمودار مربوط به چندین سل مجاور را داشته باشید.
این امکان در اکسل 2007 وجود داره ولی در 2003 باید از طریق نوشتن کد انجام بگیره و یا بصورت add ins ساخته شده و استفاده بشه.
من این کد رو دانلود کردم و برای شما هم میگذارم امیدوارم که مفید باشد.
Function LineChart(Points As Range, Color As Long) As String
Const cMargin = 2
Dim rng As Range, arr() As Variant, i As Long, j As Long, k As Long
Dim dblMin As Double, dblMax As Double, shp As Shape
Set rng = Application.Caller
ShapeDelete rng
For i = 1 To Points.Count
If j = 0 Then
j = i
ElseIf Points(, j) > Points(, i) Then
j = i
End If
If k = 0 Then
k = i
ElseIf Points(, k) < Points(, i) Then
k = i
End If
Next
dblMin = Points(, j)
dblMax = Points(, k)
With rng.Worksheet.Shapes
For i = 0 To Points.Count - 2
Set shp = .AddLine( _
cMargin + rng.Left + (i * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
cMargin + rng.Top + (dblMax - Points(, i + 1)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin), _
cMargin + rng.Left + ((i + 1) * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
cMargin + rng.Top + (dblMax - Points(, i + 2)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin))
On Error Resume Next
j = 0: j = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(j)
arr(j) = shp.Name
Next
With rng.Worksheet.Shapes.Range(arr)
.Group
If Color > 0 Then .Line.ForeColor.RGB = Color Else .Line.ForeColor.SchemeColor = -Color
End With
End With
LineChart = ""
End Function
Sub ShapeDelete(rngSelect As Range)
Dim rng As Range, shp As Shape, blnDelete As Boolean
For Each shp In rngSelect.Worksheet.Shapes
blnDelete = False
Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
If Not rng Is Nothing Then
If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
End If
If blnDelete Then shp.Delete
Next
End Sub
[attachment=54]