excel拷贝相对应的sheet

拷贝对应的sheet之前做的是一次拷贝一张sheet，显然太低级，这次做了一个升级，一次可以拷贝n张sheet，并且根据名字自动匹配，将拷贝的报表名字显示在相应的单元格里。不过之前测试的选择性粘贴只拷贝数值而不拷贝链接并没有成功。

Option Explicit

'作者: 黄立
'邮箱: ekinasm@ gmail.com
'一次拷贝多张报表，自动匹配sheet名字

Const c_numOfWorkBook As Integer = 76       'workbook的数量
Const c_reportName As String = "xSAPtemp"
Const c_listRow As Long = 2              '显示报表拷贝清单的行号
Const c_listCol As Long = 7              '显示报表拷贝清单的列号
Dim AppObject As New appClass

Sub Init()
'   Called by Workbook_Open
    Set AppObject.AppEvents = Application
End Sub

Sub ProtectMySheet(myWorkbook As Workbook)
    Dim tempSheet As Worksheet
    For Each tempSheet In myWorkbook.Worksheets
        tempSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowUsingPivotTables:=True
    Next
End Sub

Sub UnProtectMySheet(myWorkbook As Workbook)
    Dim tempSheet As Worksheet
    For Each tempSheet In myWorkbook.Worksheets
        tempSheet.Unprotect
    Next
End Sub
Sub GetRunningObject()
    Dim appExcel As Application
    Dim CopyWorkbook As Workbook                         '72报表的工作簿
    Dim allQuery(c_numOfWorkBook) As Workbook            '所有打开的报表
'    Dim isRunning As Boolean            '报表运行的标志
    Dim count As Integer                '打开报表的数量
    Dim i As Integer
    '解除保护
    Application.ScreenUpdating = False
    UnProtectMySheet ThisWorkbook
    Application.ScreenUpdating = True
    '清除拷贝报表清单
    ClearList c_listRow, c_listCol
    Set appExcel = GetObject(, "excel.application")
    '找到打开的报表，找到后IsRunning置为true,否则为false
    '同时统计打开的报表,如果没有打开的报表则退出程序
    count = 0
    For Each CopyWorkbook In appExcel.Workbooks
        If Left(CopyWorkbook.Name, 8) = c_reportName Then
            '查找所有的打开报表
            Set allQuery(count) = CopyWorkbook
            count = count + 1
        End If
    Next
    '执行拷贝并将拷贝的报表显示在本次拷贝报表清单中
    For i = 0 To count - 1
        CopyReportWorkSheet ThisWorkbook, allQuery(i), c_listRow + i, c_listCol
    Next i
    '写保护
    ProtectMySheet ThisWorkbook
    '给出拷贝成功信息
    MsgBox "拷贝了" & i & "张报表!"
End Sub

'将检测到的workbook全部拷贝到target中
'source: 即打开的报表
'target: 即含有勾稽关系的workbook
'p_row: 写进本次拷贝清单的行号
'p_col: 写进本次拷贝的列号
Sub CopyReportWorkSheet(target As Workbook, source As Workbook, p_row As Long, p_col As Long)
    Dim sheetIndex As Integer       '拷贝sheet的位置
    Dim targetSheet As Worksheet    'target的sheet
    Dim sourceSheet As Worksheet    'source的sheet
    Dim toBeCopy As Worksheet       '将要被拷贝的worksheet
    Dim isError As Boolean          '错误标识
    '遍历source和target为了得到相同名字的sheet
    isError = True
    For Each sourceSheet In source.Worksheets
        For Each targetSheet In target.Worksheets
            If targetSheet.Name = sourceSheet.Name Then
                isError = False
                Set toBeCopy = sourceSheet
                '得到sheet的序号
                sheetIndex = targetSheet.Index
                '一旦找到便可退出
                Exit For
            End If
        Next
    Next
    '未找到相对应的报表则报错
    If isError Then
        MsgBox "未找到相对应的报表，请注意报表名字是否改动过"
        Exit Sub
    Else
        'NULL
    End If
    '开始拷贝
    toBeCopy.Range("A1:AZ500").Copy Destination:=target.Worksheets(sheetIndex).Range("B2")
'    toBeCopy.Range("A1:AZ500").Copy
'    target.Worksheets(sheetIndex).Select
'    target.Worksheets(sheetIndex).Range("B2").Select
'
'    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'        :=False, Transpose:=False
    '列出清单
    ThisWorkbook.Worksheets("工作表目录").Cells(p_row, p_col).Value = toBeCopy.Name
End Sub

'将上次拷贝的清单删除
'p_col: 为将要清楚的行号
'p_row: 为将要清楚的列号
Sub ClearList(p_row As Long, p_col As Long)
    While ThisWorkbook.Worksheets("工作表目录").Cells(p_row, p_col).Value <> ""
        ThisWorkbook.Worksheets("工作表目录").Cells(p_row, p_col).Clear
        p_row = p_row + 1
    Wend
End Sub