请高手帮我把此代码添加个按钮！！

sl8831

请高手帮我把以下代码添加个按钮 谢谢  可以拆分附件的表格

Sub Macro1()
    Dim cnn As Object, rs As Object
    Dim SQL$, arr, i%, desk$, a As Shape, sh As Worksheet
    Set sh = ActiveSheet
    If Val(Right(Application.OperatingSystem, 4)) >= 6 Then
        desk = Environ("USERPROFILE") & "\Desktop\"
    Else
        desk = Environ("USERPROFILE") & "\桌面\"
    End If
    Set cnn = CreateObject("ADODB.Connection")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    cnn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
    SQL = "select distinct 地区 from [Sheet1$] where 地区 is not null"
    arr = cnn.Execute(SQL).GetRows
    For i = 0 To UBound(arr, 2)
        SQL = "Select * From [Sheet1$] Where 地区='" & arr(0, i) & "'"
        Set rs = CreateObject("ADODB.Recordset")
        rs.Open SQL, cnn, 1, 3
        sh.Copy
        With ActiveWorkbook
            With .Sheets(1)
                .[a1].CurrentRegion.Offset(1 + rs.RecordCount).Clear
                .[a2].CopyFromRecordset rs
                For Each a In .Shapes
                    a.Delete
                Next
            End With
            .SaveAs desk & arr(0, i) & ".xlsx"
            .Close
        End With
    Next
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

yaojil

这样就 OK 啦 07 版

[ 本帖最后由 yaojil 于 2011-1-19 17:19 编辑 ]

sl8831

不好意思  我没说清楚
我每天要拆分不同的表 所以想做一个 有按钮的exce   打开后  添加我要拆分的表 完成拆分 附件的表只是个例子

yaojil

楼主看看这样行吗？

[ 本帖最后由 yaojil 于 2011-1-19 17:50 编辑 ]

yaojil

添加了工具栏显示，没有07 无法测试

[ 本帖最后由 yaojil 于 2011-1-20 10:29 编辑 ]