Copy sheet corresponding to excel

Before copying the corresponding sheet, we copied a sheet at a time, which is obviously too low-level. This time we made an upgrade, we could copy n sheets at a time, and automatically matched according to the name, display the copied report name in the corresponding cell. However, in the previous test, only copying a value without copying a link was not successful.

Option explicit

'Author: Huang Li
'Email: ekinasm @ gmail.com
'Copy multiple reports at a time and automatically match the sheet name

Const c_numofworkbook as integer = 76' Number of workbooks
Const c_reportname as string = "xsaptemp"
Const c_listrow as long = 2' shows the row number of the report copy list
Const c_listcol as long = 7' displays the column number of the report copy list
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, allowusingtransferttables: = 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 report workbooks
Dim allquery (c_numofworkbook) as workbook all open reports
'Dim isrunning as boolean' report running flag
Dim count as integer 'Number of opened reports
Dim I as integer
'Unprotected
Application. screenupdating = false
Unprotectmysheet thisworkbook
Application. screenupdating = true
'Clear the copy report list
Clearlist c_listrow, c_listcol
Set appexcel = GetObject (, "Excel. application ")
'Locate the open report, and set isrunning to true; otherwise, set isrunning to false.
'Both open reports are counted. If no report is opened, exit the program.
Count = 0
For each copyworkbook in appexcel. workbooks
If left (copyworkbook. Name, 8) = c_reportname then
'Find all open reports
Set allquery (count) = copyworkbook
Count = count + 1
End if
Next
'Execute the copy operation and display the copied report in the copy report list.
For I = 0 to count-1
Copyreportworksheet thisworkbook, allquery (I), c_listrow + I, c_listcol
Next I
'Write Protection
Protectmysheet thisworkbook
'The copy success message is displayed.
Msgbox "copied" & I! "
End sub

'Copy all the detected workbooks to the target.
'Source: an open report
'Target: A Workbook with a checksum relationship
'P _ row: the row number written into this copy list
'P _ Col: the column number written into this copy
Sub copyreportworksheet (target as workbook, source as workbook, p_row as long, p_col as long)
Dim sheetindex as integer 'Copy the sheet location
Dim targetsheet as worksheet 'target's sheet
Dim sourcesheet as worksheet 'source's sheet
Dim tobecopy as worksheet 'the worksheet to be copied
Dim iserror as Boolean 'error ID
'Traverse source and target to get sheet with the same name
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
'Get the sheet sequence number.
Sheetindex = targetsheet. Index
'Exit once found
Exit
End if
Next
Next
'If no corresponding report is found, an error is returned.
If iserror then
Msgbox "no corresponding report found. Please note whether the report name has been changed"
Exit sub
Else
'Null
End if
'Start copying
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
'List
Thisworkbook. worksheets ("worksheet directory"). cells (p_row, p_col). value = tobecopy. Name
End sub

'Delete the last copied list
'P _ Col: the row number to be clear
'P _ row: column number to be clear
Sub clearlist (p_row as long, p_col as long)
While thisworkbook. worksheets ("worksheet directory"). cells (p_row, p_col). value <> ""
Thisworkbook. worksheets ("worksheet directory"). cells (p_row, p_col). Clear
P_row = p_row + 1
Wend
End sub