保存工作表区域内容，用指定单元格内容命名

zhaogang1960

看来原工作簿有公式，使用数组就不会有公式了：
Private Sub CommandButton1_Click()
    Dim arr '声明变量
    arr = Range("A1:D15") '请自己调整区域大小
    Application.ScreenUpdating = False '关闭屏幕刷新,以加快运行速度
    Application.DisplayAlerts = False '关闭警告，如果D盘已经存在要保存的工作簿，就覆盖该工作簿而不显示警告框
    With Workbooks.Add(xlWBATWorksheet) '新建一个只有1张工作表的工作簿
        .Sheets(1).Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
        .SaveAs Filename:="D:\" & [a2] & ".xls" '保存在D盘'另存为D盘，此语句可以通过录制宏(另存为)获得
'        .SaveAs Filename:="D:\新建文件夹\" & [a2] & ".xls"'文件夹请自己修改，新建文件夹是否存在没有作判断,请确保它存在
        .Close '关闭新建工作簿
    End With
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

wyt981

大侠的方法的确干净，我的表复制过去就像是选择粘贴里的数值效果 ，可是我还是想要些边框修饰下表哈，还有什么好方法吗

zhaogang1960

不知道你需要什么边框，下面代码仅加上了一般边框：
Private Sub CommandButton1_Click()
    Dim arr '声明变量
    arr = Range("A1:D15") '请自己调整区域大小
    Application.ScreenUpdating = False '关闭屏幕刷新,以加快运行速度
    Application.DisplayAlerts = False '关闭警告，如果D盘已经存在要保存的工作簿，就覆盖该工作簿而不显示警告框
    With Workbooks.Add(xlWBATWorksheet) '新建一个只有1张工作表的工作簿
        With .Sheets(1).Cells(1, 1).Resize(UBound(arr), UBound(arr, 2))
            .Value = arr
            .Borders.LineStyle = xlContinuous '加边框
        End With
        .SaveAs Filename:="D:\" & [a2] & ".xls" '保存在D盘'另存为D盘，此语句可以通过录制宏(另存为)获得
'        .SaveAs Filename:="D:\新建文件夹\" & [a2] & ".xls"'文件夹请自己修改，新建文件夹是否存在没有作判断,请确保它存在
        .Close '关闭新建工作簿
    End With
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

wyt981

我做了个表，保存的表打开时显示"此工作簿包含到其他数据源的链接"对话框。能否在代码里添加以消除，并保持表中的格式和状态。

zhaogang1960

测试了好几遍没有出现上述现象，有VLOOKUP公式，没有其他链接

wyt981

你先关掉模板的表，再打开保存的表，看看

wyt981

是不是有对话框出现，能用代码消掉就完美了。还请大侠费心给看看。

zhaogang1960

测试出来了，看来我没有看懂公式，只好去掉公式了：
Private Sub CommandButton1_Click()
    Dim rng As Range
    Set rng = ActiveSheet.Range("a1:f20")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Workbooks.Add(xlWBATWorksheet)
        rng.Copy .Sheets(1).Cells(1, 1)
        With .Sheets(1).UsedRange
            .Value = .Value '去公式
        End With
        .SaveAs Filename:="D:\" & [a9] & ".xls" '保存在D盘
'        .SaveAs Filename:="D:\新建文件夹\" & [a2] & ".xls"'文件夹请自己修改，新建文件夹是否存在没有作判断,请确保它存在
        .Close
    End With
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub
Book1.rar (14.28 KB, 下载次数: 126)

2009-10-4 22:04 上传

点击文件名下载附件

wyt981

你还谦虚什么，真是高手啊，问题解决了。不管是红猫还是紫猫能解决老鼠的就是神猫。感谢大侠的帮助啊，非常感谢。要是再遇到问题还要麻烦你的。

duoduoduo

感谢大侠指点，本人也获益匪浅