| 查看: 1076 | 回复: 4 | |||
mystar金虫 (文坛精英)
|
[交流]
【求助】excel宏问题【已解决】
|
|
目的是将一个excel文件追加到另一个excel文件 －－－－－－－－－－－－－－－－－ Sub MergeSheets() Dim SrcBook As Workbook, SrcSht As Worksheet Dim Filename As Variant ' Get the filename Filename = Application.GetOpenFilename("Excel Files (*.xls), *.xls,CSV Files (*.csv), *.csv,Text Files (*.txt), *.txt,PRN Files (*.prn), *.prn", 1, "请选择追加记录的来源档"  If Filename = False Then Exit Sub End If Set SrcBook = Workbooks.Open(Filename) '如果两个档案的工作表数量不等则取消执行 If ThisWorkbook.Sheets.Count <> SrcBook.Sheets.Count Then MsgBox "两个档案的工作表数量不等" & vbCrLf & _ ThisWorkbook.Name & " = " & ThisWorkbook.Sheets.Count & "个工作表" & vbCrLf & _ SrcBook.Name & " = " & SrcBook.Sheets.Count & "个工作表" SrcBook.Close Exit Sub End If n = 1 Application.ScreenUpdating = False For Each SrcSht In SrcBook.Worksheets '取得复制范围，如果有标题行不复制，请更改 "A1:IV"，例如 "A2:IV" SrcSht.Range("A1:IV" & SrcSht.Range("A65536" .End(xlUp).Row).CopyThisWorkbook.Worksheets(n).Activate Range("A65536" .End(xlUp).Offset(1, 0).PasteSpecialApplication.CutCopyMode = False Range("A1" .Activaten = n + 1 Next ThisWorkbook.Worksheets(1).Activate SrcBook.Close Application.ScreenUpdating = True End Sub －－－－－－－－－－－－－－－－－－－－－－－－ 有一个出错信息 改成 －－－－－－－－－－－－－－ －－－－－－－－－－－－－－－－－－ Sub MergeSheets() Dim SrcBook As Workbook, SrcSht As Worksheet Dim Filename As Variant ' Get the filename Filename = Application.GetOpenFilename("Excel Files (*.xls), *.xls,CSV Files (*.csv), *.csv,Text Files (*.txt), *.txt,PRN Files (*.prn), *.prn", 1, "请选择追加记录的来源档" If Filename = False Then Exit Sub End If Set SrcBook = Workbooks.Open(Filename) '如果两个档案的工作表数量不等则取消执行 If ThisWorkbook.Sheets.Count <> SrcBook.Sheets.Count Then MsgBox "两个档案的工作表数量不等" & vbCrLf & _ ThisWorkbook.Name & " = " & ThisWorkbook.Sheets.Count & "个工作表" & vbCrLf & _ SrcBook.Name & " = " & SrcBook.Sheets.Count & "个工作表" SrcBook.Close Exit Sub End If n = 1 Application.ScreenUpdating = False For Each SrcSht In SrcBook.Worksheets '取得复制范围，如果有标题行不复制，请更改 "A1:IV"，例如 "A2:IV" On Error Resume Next If Len(SrcSht.Names("TITLE" .Name) <> 0 ThenApplication.Goto Reference:=SrcSht.Range("TITLE" Selection.EntireRow.Hidden = True End If SrcSht.Range("A1:IV" & SrcSht.Range("A65536" .End(xlUp).Row).CopyThisWorkbook.Worksheets(n).Activate Range("A65536" .End(xlUp).Offset(1, 0).PasteSpecialApplication.CutCopyMode = False Range("A1" .Activaten = n + 1 Next ThisWorkbook.Worksheets(1).Activate SrcBook.Close SaveChanges:=False Application.ScreenUpdating = True End Sub －－－－－－－－－－－－－－－ 没有出错信息，但第一行会有问题。 麻烦再改改 [ Last edited by 余泽成 on 2010-12-12 at 20:31 ] |
回复此楼» 猜你喜欢
售一区SCI文章T0P，我:8O.551.O54,科目全,可十急
已经有4人回复
-
售SCI一区文章，我:8.O.55.1.O.54,科目齐全,可伽急
已经有4人回复
-
售SCI一区T0P文章，我:8.O.55.1.O.54,科目齐全,可+急
已经有4人回复
-
售SCI一区文章，我:8O5.5.1.O5.4,科目全,可伽急
已经有5人回复
-
售一区SCI文章T0P，我:8O.551.O54,科目全,可十急
已经有5人回复
-
售SCI一区T0P文章，我:8.O.55.1.O54,科目全,可伽急
已经有5人回复
-
售SCI一区T0P文章，我:8.O55.1.O.54,科目全,可十急
已经有5人回复
-
售SCI一区T0P文章，我:8.O.55.1.O.54,科目齐全,可+急
已经有5人回复
-
售SCI文章，我:8O.5.5.1O.54,科目全,可十急
已经有4人回复
-
售SCI一区T0P文章，我:8O.55.1.O.54,科目全,可伽急
已经有4人回复
» 本主题相关价值贴推荐，对您同样有帮助:
- 【讲座】彻底理解Excel中的宏（马成功）
已经有340人回复
- 急！X射线衍射相同，但是颗粒宏观大小形状不同，如何解释？
已经有8人回复
- 能说明 微观结构 对 材料宏观力学影响 的 示意图【PPT用图】，非常感谢！
已经有6人回复
- excel中的加载宏
已经有7人回复
- 中国科学技术大学俞书宏教授课题组——生物纳米复合材料
已经有24人回复
- 关于excel宏的问题！急等！
已经有2人回复
- 计划书，word2007,宏设置问题
已经有5人回复
- 【交流】对多晶的取向分析在宏观上有哪些测试手段
已经有22人回复
- 请教高手，插入文献时,提示由于宏设置问题不能插入？
已经有5人回复
mystar
金虫 (文坛精英)
- 应助: 0 (幼儿园)
- 贵宾: 1.2
- 金币: 1534.1
- 散金: 1520
- 红花: 2
- 沙发: 1
- 帖子: 10236
- 在线: 667.3小时
- 虫号: 91402
- 注册: 2005-09-05
2楼2010-10-21 17:36:33
Lily_melon
铜虫 (小有名气)
- 应助: 0 (幼儿园)
- 金币: 475.4
- 沙发: 6
- 帖子: 281
- 在线: 17.3小时
- 虫号: 1115473
- 注册: 2010-10-07
- 性别: GG
- 专业: BB学
3楼2010-10-23 09:26:48
mystar(金币+10): ------------- 2011-04-25 18:54:31
 |
4楼2010-12-09 00:56:55
mystar
金虫 (文坛精英)
- 应助: 0 (幼儿园)
- 贵宾: 1.2
- 金币: 1534.1
- 散金: 1520
- 红花: 2
- 沙发: 1
- 帖子: 10236
- 在线: 667.3小时
- 虫号: 91402
- 注册: 2005-09-05
5楼2010-12-09 01:02:42
