永发信息网

我想用vba代码把一个文件中某一个sheet里指定区域内容复制到另一个汇总工作簿里一个指定shee

答案:1  悬赏:10  手机版
解决时间 2021-02-08 22:53
我想用vba代码把一个文件中某一个sheet里指定区域内容复制到另一个汇总工作簿里一个指定shee
最佳答案
参考代码 
private Sub bookMerge(nstart As Long, ncolumn As Integer)
'    MsgBox "欢迎使用合并工作表工具1.0" & Chr(13) & "made by excel880工作室" & Chr(13) _
'        & "本工具将合并当前目录下所有工作簿的第一个工作表到一个工作簿"
'
    Dim fs, f, f1, fc, s
    Dim wk As Workbook, sht As Worksheet
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(ThisWorkbook.Path)
    Set fc = f.Files

    Set targetWk = Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\合并.xls"
    Set targetSht = ActiveWorkbook.Sheets(1)
    targetSht.Name = "合并"
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
'    Set targetWk = Workbooks.Open(ThisWorkbook.Path & "\" & "合并.xls")
'    Set targetSht = targetWk.Sheets(1)

    k = nstart '目标表的行标

    For Each f1 In fc '遍历文件夹文件
        If f1.Name <> ThisWorkbook.Name And Right(f1.Name, 3) = "xls" And f1.Name <> "合并.xls" Then
            Set wk = Workbooks.Open(ThisWorkbook.Path & "\" & f1.Name) '打开工作簿
                'wk.Sheets(1).Copy Before:=Workbooks("合并工作表.xls").Sheets("xx")
                'ThisWorkbook.Sheets("Sheet1").Name = Left(f1.Name, Len(f1.Name) - 4)

            Set sht = wk.ActiveSheet
            If k = nstart Then '复制粘贴表头

                sht.Rows(1 & ":" & (nstart - 1)).Copy
                targetSht.Activate
                targetSht.Cells(1, 1).Select
                ActiveSheet.Paste '粘贴表头
            End If
            '************复制粘贴数据************
            irow = nstart '行标
            While sht.Cells(irow + 1, ncolumn) <> "" '以第ncolumn列数据为结束标示,确定源表的行数
                irow = irow + 1
            Wend
            sht.Rows(nstart & ":" & irow).Copy '复制源数据行
            targetSht.Activate
            targetSht.Cells(k, 1).Select
            ActiveSheet.Paste '粘贴数据
            k = k + irow - nstart + 1
            's = s & f1.Name
            's = s & vbCrLf
            wk.Close
        End If
    Next
    targetWk.Save
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ThisWorkbook.Close SaveChanges:=True
    'MsgBox s
End Sub
我要举报
如以上问答信息为低俗、色情、不良、暴力、侵权、涉及违法等信息,可以点下面链接进行举报!
大家都在看
渠东村在哪里啊,我有事要去这个地方
车厘子就是樱桃吗,车厘子的产地在哪里
为什么孟德尔用豌豆做杂交实验利用了自花传粉
欧瑞莲生活体验馆地址在什么地方,想过去办事
便利店收银机日营业额可以修改吗
我的电脑为什么删除文件时会卡死或死机?怎么
请问详细的企业词条要做怎么创建,是否免费?
为什么人晒太多的太阳后想睡觉?暖洋洋的中午
互助中介地址在什么地方,想过去办事
红烧肉做之前用过水焯吗?
GSM短消息的pdu和text模式的区别是什么
韵达快递从北京到江苏省盐城市建湖县多长时间
连鞍线地址有知道的么?有点事想过去
某车间原有吸声量为500m,经过吸声处理后,其
在牢里可以看什么样的书,哪些书是限制看的?
推荐资讯
豺狗的分布范围
要追回女朋友九十九封信怎么写
加油站(赛飞亚路)地址在什么地方,想过去办事
远成物流(蟠龙路96号附近远成物流)地址在什么
我的手机总是自动下载软件和出现广告我用手机
索日芽双语幼儿园地址在哪,我要去那里办事
宏建烧烤炉在什么地方啊,我要过去处理事情
已知高压组合互感器的电流和变比怎么算用电量
志英批发零售超市地址在哪,我要去那里办事
什么样的天文望远镜能观测到月球表面
中国渔村地址好找么,我有些事要过去
我们国家有没有防拐的专业机构?
正方形一边上任一点到这个正方形两条对角线的
阴历怎么看 ?