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

Question

如题所述

Answer 1

参考代码 

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