应《网络安全法》要求，自2017年10月1日起，未进行实名认证将不得使用互联网跟帖服务。为保障您的帐号能够正常使用，请尽快对帐号进行手机号验证，感谢您的理解与支持！

24小时热门版块排行榜    

Znn3bq.jpeg
小木虫论坛-学术科研互动平台 » 计算模拟区 » 程序语言 » 其它 » 【求助】excel宏问题【已解决】
51/1返回列表
查看: 864  |  回复: 4
只看楼主 @他人 存档 新回复提醒 (忽略) 收藏    在APP中查看

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).Copy
        
        ThisWorkbook.Worksheets(n).Activate

        Range("A65536".End(xlUp).Offset(1, 0).PasteSpecial

        Application.CutCopyMode = False
        
        Range("A1".Activate
        
        n = 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 Then
            Application.Goto Reference:=SrcSht.Range("TITLE"
            Selection.EntireRow.Hidden = True
        End If

        SrcSht.Range("A1:IV" & SrcSht.Range("A65536".End(xlUp).Row).Copy
        
        ThisWorkbook.Worksheets(n).Activate

        Range("A65536".End(xlUp).Offset(1, 0).PasteSpecial

        Application.CutCopyMode = False
        
        Range("A1".Activate
        
        n = 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 ]
回复此楼

» 猜你喜欢

» 本主题相关价值贴推荐，对您同样有帮助:
不要使自己麻木于制度化当中，而抛弃了从前的美好事物和希望。
1楼 2010-10-21 17:22:05
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

mystar

金虫 (文坛精英)
ajian04(金币+1):谢谢参与交流~ 2010-10-21 17:39:03
ajian04(金币-1):不好意思， 在楼上已经奖励过了，现收回这个金币，谢谢啊，呵呵 2010-10-21 17:39:59
ajian04:谢谢参与交流~ 2010-10-21 17:40:10
第一个宏的SrcBook.Close
源excel文件关不了，可能是错在这里。

怎样关掉源excel文件？
赞一下(3人) 回复此楼
不要使自己麻木于制度化当中，而抛弃了从前的美好事物和希望。
2楼2010-10-21 17:36:33
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

Lily_melon

铜虫 (小有名气)
看不懂呀
回复此楼
啊啊啊啊
3楼2010-10-23 09:26:48
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

看天
mystar(金币+10): ------------- 2011-04-25 18:54:31
4楼2010-12-09 00:56:55
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

mystar

金虫 (文坛精英)
已经解决。工作表个数要相同
赞一下 回复此楼
不要使自己麻木于制度化当中，而抛弃了从前的美好事物和希望。
5楼2010-12-09 01:02:42
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖
相关版块跳转 我要订阅楼主 mystar 的主题更新
51/1返回列表
普通表情 龙 兔 虎 猫 高级回复 (可上传附件)
最具人气热帖推荐 [查看全部] 作者 回/看 最后发表
[论文投稿] 有人投过CCC中国控制会议吗？ 19+3 初九凡 2026-04-26 4/200 2026-05-02 21:11 by Equinoxhua
[找工作] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 qs8kylt1wr 2026-05-01 3/150 2026-05-02 16:06 by zahslv263y
[公派出国] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 qs8kylt1wr 2026-05-01 3/150 2026-05-02 15:51 by zahslv263y
[考博] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 qs8kylt1wr 2026-05-01 3/150 2026-05-02 15:51 by zahslv263y
[教师之家] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 qs8kylt1wr 2026-05-01 3/150 2026-05-02 15:36 by zahslv263y
[论文投稿] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 qs8kylt1wr 2026-05-01 3/150 2026-05-02 15:21 by zahslv263y
[博后之家] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 qs8kylt1wr 2026-05-01 3/150 2026-05-02 15:06 by zahslv263y
[博后之家] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 d8tbypao1q 2026-05-01 3/150 2026-05-02 14:06 by zahslv263y
[教师之家] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 d8tbypao1q 2026-05-01 3/150 2026-05-02 14:06 by zahslv263y
[博后之家] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 k17zww5nna 2026-05-01 3/150 2026-05-02 10:21 by ovidyohpyz
[公派出国] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 k17zww5nna 2026-05-01 4/200 2026-05-02 10:21 by ovidyohpyz
[找工作] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 k17zww5nna 2026-05-01 4/200 2026-05-02 10:06 by ovidyohpyz
[教师之家] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 k17zww5nna 2026-05-01 3/150 2026-05-02 09:36 by dz7y1p1i98
[硕博家园] 售SCI一区T0P文章，我:8.O.5.5.1.O.5.4,科目齐全,可+急 +3 k17zww5nna 2026-05-01 5/250 2026-05-02 09:21 by dz7y1p1i98
[考博] 药化及相关博士的申请 5+3 中药学渣 2026-04-29 3/150 2026-05-01 18:14 by babero
[论文投稿] 一篇MDPI论文改变了学习工作和生活 +3 helsinglee 2026-04-29 4/200 2026-05-01 11:45 by bobvan
[有机交流] 一个化合物的合成路线：CAS:367929-02-0 名称：8β-乙烯基雌二醇 50+4 zhquanbing 2026-04-28 4/200 2026-04-30 22:45 by zyqchem
[文学芳草园] 太白金星有点烦 +3 yexuqing 2026-04-27 3/150 2026-04-30 21:56 by myrtle
[基金申请] 收到国自然专家邀请后几年才会有本子送过来评 +3 barley5 2026-04-30 3/150 2026-04-30 14:58 by aspect3000
[论文投稿] 有没有快的中文核心比较快录用的，纳米材料光催化 5+3 2914439618 2026-04-27 4/200 2026-04-29 08:59 by 北京莱茵润色
信息提示
关闭
请填处理意见
关闭