M
marcia2026
Can anyone tell me why this routine failed. The message that I get is the
"Copy method failed"
Help!!
'
===============================================================================
'Common Functions required for all routines:
'
===============================================================================
Function LastRow(wks As Worksheet)
On Error Resume Next
LastRow = wks.Cells.Find(What:="*", _
After:=wks.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(wks As Worksheet)
On Error Resume Next
LastCol = wks.Cells.Find(What:="*", _
After:=wks.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Function SheetExists(sSht As String, Optional wkb As Workbook) As Boolean
' Returns true if Sheet sSht exists in workbook wkb
' If wkb is not specified, the ActiveWorkbook is tested
On Error Resume Next
SheetExists = Not IIf(wkb Is Nothing, ActiveWorkbook, wkb).Sheets(sSht)
Is Nothing
End Function
Function DeleteSheet(sSht As String, Optional wkb As Workbook) As Boolean
' Deletes sheet sSht if it exists.
On Error Resume Next
If SheetExists(sSht, wkb) Then
Application.DisplayAlerts = False
If wkb Is Nothing Then
ActiveWorkbook.Sheets(sSht).Delete
Else
wkb.Sheets(sSht).Delete
End If
Application.DisplayAlerts = True
DeleteSheet = Err.Number = 0
End If
End Function
'
===============================================================================
Sub CreateNewWorkbook2()
'Creates new "Current" workbook
Dim wksDst As Worksheet
Dim wks As Worksheet
Dim iRowLst As Long
Dim iRowBeg As Long
Dim iRowEnd As Long
Dim rCopy As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
DeleteSheet "Previous"
Sheets("Outstanding").Name = "Previous"
'Add and format worksheet with the name "Current"
DeleteSheet "Current"
Application.Run "PERSONAL.XLS!CopyWorksheet1"
Application.Run "PERSONAL.XLS!FormatCurrentSheet"
'AutoFit the column width in the wksDst sheet
.Goto wksDst.Range("A1")
wksDst.Columns.AutoFit
.ScreenUpdating = True
.EnableEvents = True
.ScreenUpdating = False
.EnableEvents = False
'Create "TotalForMonth" Worksheet
DeleteSheet ("TotalForMonth")
Set wksDst = ActiveWorkbook.Worksheets.Add
wksDst.Name = "TotalForMonth"
.Run "PERSONAL.XLS!FormatSheets"
'Fill in the start row
iRowBeg = 2
'loop through all worksheets and copy the data to the wksDst
For Each wks In ActiveWorkbook.Worksheets
'Loop through the worksheets required
If wks.Name <> wksDst.Name Then
'Find the last row with data on the wksDst and wks
iRowEnd = LastRow(wksDst)
iRowLst = LastRow(wks)
'If wks is not empty and if the last row >= iRowBeg copy the
rCopy
If iRowLst > 0 And iRowLst >= iRowBeg Then
'Set the range that you want to copy
Set rCopy = wks.Range(wks.Rows(2), wks.Rows(iRowLst - 1))
'Test if there enough rows in the wksDst to copy all the
data
If iRowEnd + rCopy.Rows.Count > wksDst.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
With rCopy
wksDst.Cells(iRowEnd + 1, "A").Resize(.Rows.Count,
..Columns.Count).Value = .Value
End With
'Optional: This will copy the sheet name in the H column
wksDst.Cells(iRowEnd + 1,
"L").Resize(rCopy.Rows.Count).Value = wks.Name
End If
End If
Next
'Enter Formulas
Range("J2").FormulaR1C1 = "=IF(RC[-1]=""R"",RC[-2],"""")"
Range("K2").FormulaR1C1 = "=IF(RC[-2]<>""R"",RC[-3],"""")"
'Extend Formulas to end of table
Range("J2:K2").AutoFill Destination:=Range("J2:K" &
Range("A2").End(xlDown).Row)
'Add Totals
Range("A1").End(xlDown).Range("H2,J2,K2").FormulaR1C1 =
"=Sum(R2C:R[-1]C)"
ExitTheSub:
.Goto wksDst.Cells(1)
wksDst.Columns.AutoFit
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub CopyWorksheet1()
Const sWksSrc As String = "Summary" ' Name of the Worksheet to be
copied
Const sWksDst As String = "Current" ' Name the copied Worksheet will
be given
Dim sFilt As String
Dim sFile As String
Dim wkbDst As Workbook
Dim wkbSrc As Workbook
sFilt = "Excel Files, *.xls;*.xla;*.csv, All Files, *.*"
sFile = Application.GetOpenFilename(sFilt, 1)
If sFile = "False" Then Exit Sub
Set wkbDst = ThisWorkbook
Set wkbSrc = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
Application.ScreenUpdating = False
If Not SheetExists(sWksSrc, wkbSrc) Then
MsgBox sWksSrc & " was not found in " & wkbSrc.Name
ElseIf SheetExists(sWksDst, wkbDst) Then
MsgBox sWksDst & " already exists in " & wkbDst.Name & vbCrLf _
& "Two worksheets can not have the same name."
Else
wkbSrc.Worksheets(sWksSrc).Copy _
After:=wkbDst.Worksheets(wkbDst.Worksheets.Count) <<<<<<<
this is where it fails.>>>>>
ActiveSheet.Name = sWksDst
End If
wkbSrc.Close SaveChanges:=False
Application.ScreeenUpdating = True
End Sub
"Copy method failed"
Help!!
'
===============================================================================
'Common Functions required for all routines:
'
===============================================================================
Function LastRow(wks As Worksheet)
On Error Resume Next
LastRow = wks.Cells.Find(What:="*", _
After:=wks.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(wks As Worksheet)
On Error Resume Next
LastCol = wks.Cells.Find(What:="*", _
After:=wks.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Function SheetExists(sSht As String, Optional wkb As Workbook) As Boolean
' Returns true if Sheet sSht exists in workbook wkb
' If wkb is not specified, the ActiveWorkbook is tested
On Error Resume Next
SheetExists = Not IIf(wkb Is Nothing, ActiveWorkbook, wkb).Sheets(sSht)
Is Nothing
End Function
Function DeleteSheet(sSht As String, Optional wkb As Workbook) As Boolean
' Deletes sheet sSht if it exists.
On Error Resume Next
If SheetExists(sSht, wkb) Then
Application.DisplayAlerts = False
If wkb Is Nothing Then
ActiveWorkbook.Sheets(sSht).Delete
Else
wkb.Sheets(sSht).Delete
End If
Application.DisplayAlerts = True
DeleteSheet = Err.Number = 0
End If
End Function
'
===============================================================================
Sub CreateNewWorkbook2()
'Creates new "Current" workbook
Dim wksDst As Worksheet
Dim wks As Worksheet
Dim iRowLst As Long
Dim iRowBeg As Long
Dim iRowEnd As Long
Dim rCopy As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
DeleteSheet "Previous"
Sheets("Outstanding").Name = "Previous"
'Add and format worksheet with the name "Current"
DeleteSheet "Current"
Application.Run "PERSONAL.XLS!CopyWorksheet1"
Application.Run "PERSONAL.XLS!FormatCurrentSheet"
'AutoFit the column width in the wksDst sheet
.Goto wksDst.Range("A1")
wksDst.Columns.AutoFit
.ScreenUpdating = True
.EnableEvents = True
.ScreenUpdating = False
.EnableEvents = False
'Create "TotalForMonth" Worksheet
DeleteSheet ("TotalForMonth")
Set wksDst = ActiveWorkbook.Worksheets.Add
wksDst.Name = "TotalForMonth"
.Run "PERSONAL.XLS!FormatSheets"
'Fill in the start row
iRowBeg = 2
'loop through all worksheets and copy the data to the wksDst
For Each wks In ActiveWorkbook.Worksheets
'Loop through the worksheets required
If wks.Name <> wksDst.Name Then
'Find the last row with data on the wksDst and wks
iRowEnd = LastRow(wksDst)
iRowLst = LastRow(wks)
'If wks is not empty and if the last row >= iRowBeg copy the
rCopy
If iRowLst > 0 And iRowLst >= iRowBeg Then
'Set the range that you want to copy
Set rCopy = wks.Range(wks.Rows(2), wks.Rows(iRowLst - 1))
'Test if there enough rows in the wksDst to copy all the
data
If iRowEnd + rCopy.Rows.Count > wksDst.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
With rCopy
wksDst.Cells(iRowEnd + 1, "A").Resize(.Rows.Count,
..Columns.Count).Value = .Value
End With
'Optional: This will copy the sheet name in the H column
wksDst.Cells(iRowEnd + 1,
"L").Resize(rCopy.Rows.Count).Value = wks.Name
End If
End If
Next
'Enter Formulas
Range("J2").FormulaR1C1 = "=IF(RC[-1]=""R"",RC[-2],"""")"
Range("K2").FormulaR1C1 = "=IF(RC[-2]<>""R"",RC[-3],"""")"
'Extend Formulas to end of table
Range("J2:K2").AutoFill Destination:=Range("J2:K" &
Range("A2").End(xlDown).Row)
'Add Totals
Range("A1").End(xlDown).Range("H2,J2,K2").FormulaR1C1 =
"=Sum(R2C:R[-1]C)"
ExitTheSub:
.Goto wksDst.Cells(1)
wksDst.Columns.AutoFit
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub CopyWorksheet1()
Const sWksSrc As String = "Summary" ' Name of the Worksheet to be
copied
Const sWksDst As String = "Current" ' Name the copied Worksheet will
be given
Dim sFilt As String
Dim sFile As String
Dim wkbDst As Workbook
Dim wkbSrc As Workbook
sFilt = "Excel Files, *.xls;*.xla;*.csv, All Files, *.*"
sFile = Application.GetOpenFilename(sFilt, 1)
If sFile = "False" Then Exit Sub
Set wkbDst = ThisWorkbook
Set wkbSrc = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
Application.ScreenUpdating = False
If Not SheetExists(sWksSrc, wkbSrc) Then
MsgBox sWksSrc & " was not found in " & wkbSrc.Name
ElseIf SheetExists(sWksDst, wkbDst) Then
MsgBox sWksDst & " already exists in " & wkbDst.Name & vbCrLf _
& "Two worksheets can not have the same name."
Else
wkbSrc.Worksheets(sWksSrc).Copy _
After:=wkbDst.Worksheets(wkbDst.Worksheets.Count) <<<<<<<
this is where it fails.>>>>>
ActiveSheet.Name = sWksDst
End If
wkbSrc.Close SaveChanges:=False
Application.ScreeenUpdating = True
End Sub