[已解决]备份模块问题修改

icenotcool

各位老师，想请老师帮我看看我的“报表”的“备份年度总表”按钮的备份模块问题出在哪儿，为什么，详情在附件内，谢谢老师了！附件A47:M55区域没有备份成功到，应该怎样修改呢？附件 示例11.rar (16.94 KB, 下载次数: 12)

2014-2-28 17:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

zjdh

2014-2-28 17:43

Sub 另存工作表保留格式()
    Dim arr, myname$, whname$, st$, shap As Shape
    arr = ThisWorkbook.Sheets(1).UsedRange
    myname = Application.GetOpenFilename("excel文件,*.xls*")
    If myname <> "False" Then
        With Workbooks.Open(myname)
            st = Application.InputBox("请输入要保存的工作表名", "输入")
            .Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = st
            ThisWorkbook.Sheets(1).UsedRange.Copy
            .Sheets(st).[a1].PasteSpecial Paste:=xlPasteFormats
            .Sheets(st).[a1].PasteSpecial Paste:=xlPasteColumnWidths
            .Sheets(st).[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
            .Close True
        End With
   End If
End Sub

跳转到最佳答案楼层

zjdh

Sub 另存工作表保留格式()
    Dim arr, myname$, whname$, st$, shap As Shape
    arr = ThisWorkbook.Sheets(1).UsedRange
    myname = Application.GetOpenFilename("excel文件,*.xls*")
    If myname <> "False" Then
        With Workbooks.Open(myname)
            st = Application.InputBox("请输入要保存的工作表名", "输入")
            .Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = st
            ThisWorkbook.Sheets(1).UsedRange.Copy
            .Sheets(st).[a1].PasteSpecial Paste:=xlPasteFormats
            .Sheets(st).[a1].PasteSpecial Paste:=xlPasteColumnWidths
            .Sheets(st).[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
            .Close True
        End With
   End If
End Sub

hwc2ycy

A47:M55与上面的数据间隔了一空行。
要么你用usedrange来搞定。

hwc2ycy

1. Sub 另存工作表保留格式()
   
2.     Dim arr, myname$, whname$, st$, shap As Shape
   
3.     arr = ThisWorkbook.Sheets(1).[a1].CurrentRegion
   
4.     myname = Application.GetOpenFilename("excel文件,*.xls*")
   
5.     If myname <> "False" Then
   
6.         With Workbooks.Open(myname)
   
7.             st = Application.InputBox("请输入要保存的工作表名", "输入")
   
8.             .Sheets.Add after:=Sheets(Sheets.Count)
   
9.             ActiveSheet.Name = st
   
10.             ThisWorkbook.Sheets(1).UsedRange.Copy
    
11.             .Sheets(st).[a1].PasteSpecial Paste:=xlPasteFormats
    
12.             .Sheets(st).[a1].PasteSpecial Paste:=xlPasteColumnWidths
    
13.             .Sheets(st).[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
14.             .Close True
    
15.         End With
    
16.     Else
    
17.         Exit Sub
    
18.     End If
    
19. End Sub
    

复制代码

icenotcool

谢谢zjdh 老师和hwc2ycy 老师的解答，zjdh 老师的语句测试没有问题，但是hwc2ycy 老师的不行，第二个表格区域是空白的？