Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Copy worksheet from one workbook to another
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 48
Default Copy worksheet from one workbook to another
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").FormulaR 1C1 =
"=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



Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 9,101
Default Copy worksheet from one workbook to another
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").FormulaR 1C1 =
"=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



Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 48
Default Copy worksheet from one workbook to another
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").FormulaR 1C1 =
"=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



Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 48
Default Copy worksheet from one workbook to another
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").FormulaR 1C1 =
"=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



Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Copy worksheet from one workbook to a master workbook mvannatta Excel Worksheet Functions 3 April 15th 09 08:32 PM
How to Copy entire Worksheet from Workbook S to Workbook D kris Excel Programming 3 June 20th 07 02:03 PM
Copy Data from Workbook into specific Worksheet in other Workbook? kingdt Excel Discussion (Misc queries) 1 March 16th 06 06:55 PM
How do I copy a worksheet form a workbook in my workbook Neil Atkinson Excel Programming 1 October 12th 05 12:23 PM
copy worksheet from closed workbook to active workbook using vba mango Excel Worksheet Functions 6 December 9th 04 07:55 AM


All times are GMT +1. The time now is 02:42 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement