Copy new added sheet using codename from another workbook to current workbook

srikanth sare

New Member
Joined
May 1, 2020
Messages
18
Office Version
  1. 2013
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
The Below code will copy newly added sheet using codename of another workbook to current workbook.
The Project vba is password protected
it works fine only for few workbooks and not all for all workbooks and sometime when vba is unprotected it works fine for all workbooks
kindly help in solving this error


VBA Code:
Public Function SheetFromCodeName(Name As String, wbK As Workbook) As Worksheet
    Dim Wks As Worksheet
    For Each Wks In wbK.Worksheets
        If Wks.CodeName = Name Then
           Set SheetFromCodeName = Wks
           Exit For
        End If
    Next Wks
End Function

Public Function GetLastCreatedSheet()
    Dim lastAddedSheet As Worksheet
    Dim oneSheet As Worksheet
    Set lastAddedSheet = Worksheets(1)
    For Each oneSheet In Worksheets
    If Val(Mid(oneSheet.CodeName, 6)) > Val(Mid(lastAddedSheet.CodeName, 6)) Then
            Set lastAddedSheet = oneSheet
        End If
    Next oneSheet
    GetLastCreatedSheet = lastAddedSheet.CodeName
End Function

Private Sub COPY_PROJECT()
    On Error GoTo EH
    Application.Run "TurnOff"
    
    Sheet4.Range("A1").ClearContents
    Dim Path As String
    Sheet3.Range("A1").Value = Environ("Username")
    Select Case Sheet3.Range("A1").Value
    Case "sri CA nth Sare"
    Path = "G:\srik_CA_nth\PARTNERSHIP FIRMS\SARVAHITHA DEVELOPERS\FINAL PROJECTS"
    Case "SARVAHITA"
    Path = "F:\DRIVE\PROJECTS\BP OF FINAL PROJECTS"
    End Select
   
    Dim wbK As Workbook: Set wbK = Workbooks.Open(Path & Application.PathSeparator & Sheet1.Range("Y1").Value & ".xlsb", Password:="Ssca@1818")
    Dim Wks As Worksheet: Set Wks = SheetFromCodeName(GetLastCreatedSheet, wbK)
    Wks.Cells.Copy
    Sheet4.Range("A1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False
   
    On Error Resume Next
    Sheet4.Range("A:A,D:F,H:BG,BK:BL,BP:DG,DQ:EB").EntireColumn.Delete Shift:=xlToLeft
    On Error GoTo 0

CleanUp: On Error Resume Next
         wbK.Close SaveChanges = False
         Application.Run "TurnOn"
    Exit Sub
EH: Debug.Print Err.Description  ' Do error handling
    MsgBox "Sorry, an error occured." & vbCrLf & Err.Description, vbCritical, "Error!"
    Resume CleanUp
End Sub
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

Forum statistics

Threads
1,141,062
Messages
5,704,060
Members
421,325
Latest member
tapete86

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top