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

24小时热门版块排行榜    

小木虫论坛-学术科研互动平台 » 计算模拟区 » 程序语言 » 其它 » 【求助】excel宏问题【已解决】
51/1返回列表
查看: 983  |  回复: 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

金虫 (文坛精英)
已经解决。工作表个数要相同
赞一下 回复此楼
不要使自己麻木于制度化当中，而抛弃了从前的美好事物和希望。
5楼2010-12-09 01:02:42
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖
查看全部 5 个回答

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的回帖
查看全部 5 个回答
普通表情 龙 兔 虎 猫 高级回复 (可上传附件)
最具人气热帖推荐 [查看全部] 作者 回/看 最后发表
[基金申请] 欢迎发来filecode的Mz6后的代码验证其规律 +33 医学老男孩 2026-08-13 80/4000 2026-08-17 14:40 by yq199112088
[基金申请] 感觉是下周放榜了 +3 angus9576 2026-08-17 6/300 2026-08-17 14:32 by 启萌科技
[考博] 售一区SCI文章T0P，我:8O.551.O54,科目全,可十急 +3 6GojgJvkDudM 2026-08-16 4/200 2026-08-17 13:49 by EYK67XJMj64E
[基金申请] 今天系统多次维护，明天很可能放榜！ +8 zju2000 2026-08-16 9/450 2026-08-17 12:20 by lmz0216
[硕博家园] 售SCI一区T0P文章，我:8O.55.1.O.5.4,科目齐全,可+急 +3 i7NFEVbjQMM5 2026-08-16 4/200 2026-08-17 12:10 by 4GBAYCdVQoK3
[考研] 售SCI一区T0P文章，我:8O.55.1.O.5.4,科目齐全,可+急 +3 6GojgJvkDudM 2026-08-16 4/200 2026-08-17 11:46 by 4GBAYCdVQoK3
[基金申请] 2027广东省杰青 +3 奶牛小黑 2026-08-15 6/300 2026-08-16 20:07 by 奶牛小黑
[基金申请] 咱们一起用铁证分析2026国家社科基金中标与否 +7 启萌科技 2026-08-12 26/1300 2026-08-16 12:35 by 启萌科技
[基金申请] 是这周出结果还是下周出结果？ +4 yuleib84 2026-08-11 4/200 2026-08-14 23:05 by lfy8008
[硕博家园] 读博的好处 +4 lnee 2026-08-11 4/200 2026-08-14 10:20 by ahsoarli
[基金申请] filecode +15 documentary 2026-08-10 17/850 2026-08-14 10:08 by kissu88
[基金申请] 静等基金结果 +8 gjjjzhong 2026-08-10 21/1050 2026-08-13 17:56 by 且听虎啸
[基金申请] 重要来源：本周末出结果 +10 瞬息宇宙 2026-08-12 10/500 2026-08-13 15:46 by likettle
[基金申请] Filecode 又变了，巨变 +3 WH3796 2026-08-12 4/200 2026-08-13 14:13 by 小木虫6752397
[基金申请] 分享一下我之前已中青C的计划书的filecode +4 布布和一二 2026-08-11 5/250 2026-08-13 12:56 by cratir
[基金申请] 结合人工智能，周易传统文化，filecode打分制来了，3分以上希望很大。 +3 Tide man 2026-08-12 4/200 2026-08-13 08:35 by ZJTJZ
[基金申请] 2019年青年基金涵评意见，大家看看几个A，几个B? +11 Tide man 2026-08-11 11/550 2026-08-13 07:35 by 撸猫猫
[基金申请] 帮忙看看fileCode +7 wwncly 2026-08-10 13/650 2026-08-11 19:36 by 冰心玉壶晴
[基金申请] 什么时候出结果，有咨询渠道？？？ +3 Tide man 2026-08-11 3/150 2026-08-11 17:54 by kudofaye
[基金申请] 确定了，国自然21号放榜 +6 布布和一二 2026-08-10 7/350 2026-08-10 19:15 by 2000zf36392
信息提示
关闭
请填处理意见
关闭