Copy worksheet from one workbook to another

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
 
J

Joel

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 said:
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
Click to expand...
 
M

marcia2026

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

Run-time error '424, object required.



Joel said:
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 said:
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
Click to expand...
Click to expand...
 
M

marcia2026

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

thanks,

Joel said:
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 said:
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
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Another rascally VBA SUMPRODUCT issue 2
Scattered array cells copy to scattered array cells another workbook 14
Copy Multiple Areas from One Workbook to Another 4
Copy two sheets from workbook & create new workbook 8
Copy from one worksheet to another 1
Merge Sheets 2
Runtime Error 13 - Mismatch 6
Copy a table from one workbook to ALL worksheets in a different wb 1

Top