i am getting method copy of object _worksheet failed

I have the below code.

it am getting the error method copy of object _worksheet failed

i do not know how to debug it. can anyone please give me some tips or error handler or something that can find the culprit that is causing the error.  becuase this error does not happen with all files. but only few files.

error stops at   sh.Copy

i used   On Error GoTo ErrorRoutine before   sh.Copy and at the end of the code i put

ErrorRoutine:
MsgBox "rcell: " & "Worksheet is " & Ws.Name & ", Address is " & rcell.Address & ", Value is " & rcell.Value

but this error trap did not point the error. it also gives error on this errortrap


2017-12-06-18_46_55-Microsoft-Visual.png

#If VBA7 Then
    Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type
                        
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As LongPtr
        
        Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
        
         Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As LongPtr, x As LongPtr, pos As Integer
#Else
    Private Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type
                        
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As Long
        
        Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

        
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
#End If
Private Const BIF_RETURNONLYFSDIRS = &H1


Function GetDirectory(Optional Msg) As String


'   Root folder = Desktop
    bInfo.pidlRoot = 0&

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
    
'   Type of directory to return
    bInfo.ulFlags = &H1

'   Display the dialog
    x = SHBrowseForFolder(bInfo)
    
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
       GetDirectory = ""
    End If
End Function

Sub Split_Column_Data()
Dim LR As Long, LC As Integer, i As Long, iStart As Long, iEnd As Long
Dim Ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
Dim loCol, loRow, bFoundLo
Set Rng = Nothing
On Error Resume Next
Set Rng = Application.InputBox("Select a range in the right worksheet:", "Select sheet and cell A1", , , , , , 8)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub
Set sh = Rng.Parent
If sh.ListObjects.Count > 0 Then
    bFoundLo = True
    Set lo = sh.ListObjects(1)
    loCol = Split(lo.Range.Resize(1, 1).Address, "$")(1)
       loRow = lo.Range.Resize(1, 1).Row
    If loCol <> "A" Then Range("A1:" & loCol & "1").Resize(, Range("A1:" & loCol & "1").Columns.Count - 1).EntireColumn.Delete
    If loRow > 1 Then Range("A1:A" & loRow - 1).EntireRow.Delete
    
End If
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveWorkbook.ActiveSheet
    Master = .Name
   LR = LastRow(ActiveWorkbook.ActiveSheet)
   LC = LastCol(ActiveWorkbook.ActiveSheet)
    .Range(.Cells(2, 1), Cells(LR, LC)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To LR
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add After:=Sheets(Sheets.Count)
            Set Ws = ActiveSheet
           On Error Resume Next
            Ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            .Range(.Cells(1, 1), .Cells(1, LC)).Copy Ws.Cells(1, 1)
            .Range(.Cells(1, 1), .Cells(1, LC)).Copy
            Ws.Range(Cells(1, 1), Cells(1, LC)).PasteSpecial xlPasteColumnWidths
            .Range(.Cells(iStart, 1), .Cells(iEnd, LC)).Copy Destination:=Ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With

If bFoundLo Then
    For Each Ws In ActiveWorkbook.Worksheets
        With Ws
            Set Src = Ws.Range("A1").CurrentRegion
            If Src.ListObject Is Nothing Then
                .ListObjects.Add SourceType:=xlSrcRange, Source:=Src, xlListObjectHasHeaders:=xlYes
            End If
        End With
    Next Ws
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
If MsgBox("Do you want to save the separated sheets as workbooks", vbYesNo + vbQuestion) = vbYes Then
    Folder = "Select the folder to save the workbooks"
    Folder = GetDirectory(Folder)
    If Folder = "" Then Exit Sub
    Prefix = InputBox("Enter a prefix (or leave blank)")
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xlsx"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xlsx), *.xlsx)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=51
            ActiveWorkbook.Close
        End If
     Next sh
     Application.ScreenUpdating = True
     Application.DisplayAlerts = True
End If
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

Open in new window

LVL 6
FloraAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

NorieAnalyst Assistant Commented:
What happens when you remove the On Error... stuff?
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FloraAuthor Commented:
thank you very much.

i found that one of the sheet were hidden.  that was causing it.  becuase it was not getting activated.
0
FloraAuthor Commented:
just one question.

in this part of the code.

how can i add another condition that if sheet name is not sh.Name <> Master  and it is not hidden then do the stuff

   For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> Master Then
            sh.Copy
            Fname = Folder & "\" & Prefix & sh.Name & ".xlsx"
            If Dir(Fname) <> "" Then Fname = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xlsx), *.xlsx)", _
                Title:=Fname & " exists - select file to save as")
            ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=51
            ActiveWorkbook.Close

Open in new window

0
FloraAuthor Commented:
Found it.

added if sh.visible=true
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.