Copy sheet corresponding to excel

Source: Internet
Author: User

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 @
'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
End sub

Sub unprotectmysheet (myworkbook as workbook)
Dim tempsheet as Worksheet
For each tempsheet in myworkbook. worksheets
Tempsheet. unprotect
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
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
'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
End if
'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
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
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
End sub

Contact Us

The content source of this page is from Internet, which doesn't represent Alibaba Cloud's opinion; products and services mentioned on that page don't have any relationship with Alibaba Cloud. If the content of the page makes you feel confusing, please write us an email, we will handle the problem within 5 days after receiving your email.

If you find any instances of plagiarism from the community, please send an email to: and provide relevant evidence. A staff member will contact you within 5 working days.

A Free Trial That Lets You Build Big!

Start building with 50+ products and up to 12 months usage for Elastic Compute Service

  • Sales Support

    1 on 1 presale consultation

  • After-Sales Support

    24/7 Technical Support 6 Free Tickets per Quarter Faster Response

  • Alibaba Cloud offers highly flexible support services tailored to meet your exact needs.