求问斑竹：如何对部分图表进行垂直排列呢？

FENGJUN

工作表中有多个内嵌图表，用CTL+鼠标选中其中部分图表，然后对这些图表进行垂直排列，如何实现呢？

以下代码能对工作表中所有的内嵌图表进行垂直排列:

Sub SizeAndAlignChartsV() Dim ChtWidth As Long, ChtHeight As Long Dim TopPosition As Long, LeftPosition As Long Dim ChtObj As ChartObject If ActiveChart Is Nothing Then Exit Sub 'Get size of active chart ChtWidth = ActiveChart.Parent.Width ChtHeight = ActiveChart.Parent.Height TopPosition = ActiveChart.Parent.Top LeftPosition = ActiveChart.Parent.Left Interv = 10 For Each ChtObj In ActiveSheet.ChartObjects ChtObj.Width = ChtWidth ChtObj.Height = ChtHeight ChtObj.Top = TopPosition ChtObj.Left = LeftPosition TopPosition = TopPosition + ChtObj.Height + Interv Next ChtObj End Sub

chenjun

应该是按住Shift键才能选择多个图表。 Sub MoveSelectedChart() Dim ChtOb On Error GoTo ErrorHandler '在已选择的对象集合中循环 For Each ChtOb In Selection.ShapeRange '判别ChtOb的类型 If ChtOb.Type = msoChart Then '处理图表的位置变化语句 '加在此处 End If Next ChtOb ErrorHandler: '空的错误处理 End Sub 该程序要用按快捷键或由其他程序控制执行。

FENGJUN

以下是引用chenjun在2005-2-19 15:41:00的发言： 应该是按住Shift键才能选择多个图表。 Sub MoveSelectedChart() Dim ChtOb On Error GoTo ErrorHandler '在已选择的对象集合中循环 For Each ChtOb In Selection.ShapeRange '判别ChtOb的类型 If ChtOb.Type = msoChart Then '处理图表的位置变化语句 '加在此处 End If Next ChtOb ErrorHandler: '空的错误处理 End Sub 该程序要用按快捷键或由其他程序控制执行。

To Chenjun:

附件中代码似乎总是按照所选择图表的内定名称在安排排列的先后顺序； 如何按照修改后的图表名称进行排序呢？——我想只有这样才能人为控制排列的先后顺序了。

e7irseF2.rar (15.62 KB, 下载次数: 10)

2005-2-19 18:33 上传

点击文件名下载附件

[此贴子已经被作者于2005-2-19 18:32:22编辑过]

chenjun

可以的，将图表名先传递给一个数组

FENGJUN

然后还需对数组排序...

辗转实现如下：

Private Sub CommandButton2_Click() Dim myCrt As New Collection, Crt As ChartObject

On Error GoTo ErrorHandler '在已选择的对象集合中循环 For Each ChtObj In Selection.ShapeRange '判别ChtObj的类型 If ChtObj.Type = msoChart Then 'MsgBox ChtObj.Name myCrt.Add ChtObj.Name End If Next ChtObj

ReDim myTabs(1 To myCrt.Count) For i = 1 To myCrt.Count myTabs(i) = myCrt(i) 'MsgBox myTabs(i) Next i

myTabs1 = Array_Sort(myTabs, False)

For i = 1 To UBound(myTabs1) 'MsgBox myTabs1(i) With ActiveSheet.ChartObjects(myTabs1(i)) .Width = ChtWidth .Height = ChtHeight .Top = TopPosition .Left = LeftPosition TopPosition = TopPosition + .Height + Interv End With Next i

Exit Sub

ErrorHandler: '空的错误处理 End Sub

Function Array_Sort(ArrayList As Variant, L As Boolean) As Variant Dim aCnt As Integer, bCnt As Integer Dim tempStr As String

For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1 For bCnt = aCnt + 1 To UBound(ArrayList)

If L Then 'StrComp(MyArray(I), X, tp) < 0 If StrComp(ArrayList(aCnt), ArrayList(bCnt), 1) < 0 Then tempStr = ArrayList(bCnt) ArrayList(bCnt) = ArrayList(aCnt) ArrayList(aCnt) = tempStr End If

Else

If StrComp(ArrayList(aCnt), ArrayList(bCnt), 1) > 0 Then tempStr = ArrayList(bCnt) ArrayList(bCnt) = ArrayList(aCnt) ArrayList(aCnt) = tempStr End If

End If Next bCnt Next aCnt Array_Sort = ArrayList End Function

[此贴子已经被作者于2005-2-20 13:20:40编辑过]

chenjun

差不多吧！直接将图表名赋予一个动态数组就可以了，不需要用Collection的。