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

try this . I think yu are getting a wrong status from this routine

Function SheetExists(sSht As String, Optional wkb As Workbook) As Boolean
If wb Is Nothing Then
Set wkb = ThisWorkbook
End If

SheetExists = False

For Each sht In wkb

' Returns true if Sheet sSht exists in workbook wkb
' If wkb is not specified, the ActiveWorkbook is tested
If UCase(sht.Name) = UCase(sSht) Then
SheetExists = True
Exit For
End If
End Function


"marcia2026" wrote:

> 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
>
>
>

I replaced the existing code with your suggestion, and now when it runs, I
get the message

Run-time error '424, object required.



"Joel" wrote:

> try this . I think yu are getting a wrong status from this routine
>
> Function SheetExists(sSht As String, Optional wkb As Workbook) As Boolean
> If wb Is Nothing Then <<<<<<<<<<<<<<<
> Set wkb = ThisWorkbook
> End If
>
> SheetExists = False
>
> For Each sht In wkb
>
> ' Returns true if Sheet sSht exists in workbook wkb
> ' If wkb is not specified, the ActiveWorkbook is tested
> If UCase(sht.Name) = UCase(sSht) Then
> SheetExists = True
> Exit For
> End If
> End Function
>
>
> "marcia2026" wrote:
>
> > 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
> >
> >
> >

Now I get the message:
Run-time error '424'
object required.

thanks,

"Joel" wrote:

> try this . I think yu are getting a wrong status from this routine
>
> Function SheetExists(sSht As String, Optional wkb As Workbook) As Boolean
> If wb Is Nothing Then
> Set wkb = ThisWorkbook
> End If
>
> SheetExists = False
>
> For Each sht In wkb
>
> ' Returns true if Sheet sSht exists in workbook wkb
> ' If wkb is not specified, the ActiveWorkbook is tested
> If UCase(sht.Name) = UCase(sSht) Then
> SheetExists = True
> Exit For
> End If
> End Function
>
>
> "marcia2026" wrote:
>
> > 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
> >
> >
> >