Help - now really stuck! File transfer problem

Good moring all,

I'm trying to accomplish the following:

file1.xls

copy worksheet1 from file1.xls

and then insert into file2.xls without overwriting file1.xls completely.

The reason - I have one master xls file with multiple named worksheets.
Each worksheet relates to another xls file and on a weekly basis I want the
master xls file's different worksheets updated so the worksheets are
replaced but the main master xls file is not. All I've accomplished so far
is below:

Public Sub TransferData()

'Disable screen updating while the subroutine is run
Application.ScreenUpdating = False

'Unprotect all Register worksheet
Worksheets("Register").Select
ActiveSheet.Unprotect

'Define Variables
Dim szThisFileName As String
Dim szFileName As String
Dim szWindowName As String
Dim szNotes As String
Dim szPETNumber As String
Dim Response As Integer

'Set initial values
szThisFileName = ActiveWorkbook.Name
szWindowName = "Test Risk Transfer.xls"
szFileName = "C:\" & szWindowName
iRow = 1

'Check if user wants to continue
If MsgBox("This facility is only for transfering information into " _
+ "the BISTD Central Register repository database. " _
+ "Are you sure you want to continue?", vbQuestion + vbYesNo) = vbNo
Then
Exit Sub
End If

'Check if there is any data to transfer
Worksheets("Register").Select
If ActiveSheet.Range("C2") = "" Then
MsgBox ("There are no risks in the Register to " _
+ "transfer.")
ActiveSheet.Protect
Exit Sub
End If

'Create Risk Transfer workbook on C drive
On Error GoTo ir1:
Workbooks.Add
ChDir "C:\"
ActiveWorkbook.SaveAs FileName:=szFileName, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Windows(szWindowName).Activate
Sheets.Add
ActiveSheet.Name = "Risk Transfers1"
Windows(szThisFileName).Activate

'Add column headings to Stakeholder Transfer workbook
Worksheets("Register").Select
ActiveSheet.Range("C1:V1").Select
Selection.Copy
Windows(szWindowName).Activate
Worksheets("Risk Transfers1").Select
ActiveSheet.Range("B1").Select
ActiveSheet.Paste
ActiveSheet.Range("A1") = "Project_No"
Windows(szThisFileName).Activate

'Copy risk data from the Register worksheet and transfer
'data into temporary workbook in C drive.

'Find last record in Register
Call DetermineRange(nor)

Worksheets("Register").Select
szPETNumber = ActiveSheet.Range("A2")
ActiveSheet.Range("C2:V" & nor).Copy

'Truncate Notes and Key Messages fields at 255 characters
'Worksheets("Transfer Sheet").Select
'szNotes = Worksheets("Stakeholder " & szStakeholder).Range("C66")
'szNotes = Left(szNotes, 255)
'szKeyMessages = Worksheets("Stakeholder " & szStakeholder).Range("C71")
'szKeyMessages = Left(szKeyMessages, 255)

'Paste the copied data into the Risk Transfer workbook
Windows(szWindowName).Activate
ActiveSheet.Name = "Risk Transfers1"
ActiveSheet.Range("B2").Select
ActiveSheet.Paste

'Write in the Project Number on each row
ActiveSheet.Range("A2:A" & nor) = szPETNumber

'Return to the Risk Register
Windows(szThisFileName).Activate
Application.CutCopyMode = False

'Save and close risk Transfer workbook
Windows(szWindowName).Activate
ActiveWorkbook.Save
ActiveWindow.Close
Windows(szThisFileName).Activate


'Protect Register worksheet
Worksheets("Register").Select
ActiveSheet.Protect
Worksheets("FrontScreen").Select
Exit Sub

ir1: Response = MsgBox("You already have a risk Transfer workbook " _
+ "in your C Drive. Do you want to " _
+ "delete this existing Risk Transfer workbook " _
+ "and replace it with a new version?", vbYesNo)
If Response = vbYes Then
MsgBox ("Click the Transfer Data button " _
+ "again and when prompted that there is an existing " _
+ "risk Transfer file and asking if you " _
+ "wish to replace it, click Yes.")
MsgBox ("You will have created a temporary workbook called Book
" _
+ "Book*.xls. You will need to delete this when you finish the
session.")
GoTo ir2:
Else
GoTo ir2:
End If

ir2: Windows(szThisFileName).Activate
Worksheets("Register").Select
ActiveSheet.Protect
Worksheets("FrontScreen").Select
Exit Sub
End Sub

What does the below have to do with your question? It appears to be writing
information to a new workbook, not replacing sheets in an existing workbook.
What actually is your question.

--
Regards,
Tom Ogilvy

"ohboy!" <[email protected]> wrote in message
news:[email protected]...
> Good moring all,
>
> I'm trying to accomplish the following:
>
> file1.xls
>
> copy worksheet1 from file1.xls
>
> and then insert into file2.xls without overwriting file1.xls completely.
>
> The reason - I have one master xls file with multiple named worksheets.
> Each worksheet relates to another xls file and on a weekly basis I want
the
> master xls file's different worksheets updated so the worksheets are
> replaced but the main master xls file is not. All I've accomplished so
far
> is below:
>
> Public Sub TransferData()
>
> 'Disable screen updating while the subroutine is run
> Application.ScreenUpdating = False
>
> 'Unprotect all Register worksheet
> Worksheets("Register").Select
> ActiveSheet.Unprotect
>
> 'Define Variables
> Dim szThisFileName As String
> Dim szFileName As String
> Dim szWindowName As String
> Dim szNotes As String
> Dim szPETNumber As String
> Dim Response As Integer
>
> 'Set initial values
> szThisFileName = ActiveWorkbook.Name
> szWindowName = "Test Risk Transfer.xls"
> szFileName = "C:\" & szWindowName
> iRow = 1
>
> 'Check if user wants to continue
> If MsgBox("This facility is only for transfering information into " _
> + "the BISTD Central Register repository database. " _
> + "Are you sure you want to continue?", vbQuestion + vbYesNo) =
vbNo
> Then
> Exit Sub
> End If
>
> 'Check if there is any data to transfer
> Worksheets("Register").Select
> If ActiveSheet.Range("C2") = "" Then
> MsgBox ("There are no risks in the Register to " _
> + "transfer.")
> ActiveSheet.Protect
> Exit Sub
> End If
>
> 'Create Risk Transfer workbook on C drive
> On Error GoTo ir1:
> Workbooks.Add
> ChDir "C:\"
> ActiveWorkbook.SaveAs FileName:=szFileName, FileFormat:=xlNormal, _
> Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
> CreateBackup:=False
> Windows(szWindowName).Activate
> Sheets.Add
> ActiveSheet.Name = "Risk Transfers1"
> Windows(szThisFileName).Activate
>
> 'Add column headings to Stakeholder Transfer workbook
> Worksheets("Register").Select
> ActiveSheet.Range("C1:V1").Select
> Selection.Copy
> Windows(szWindowName).Activate
> Worksheets("Risk Transfers1").Select
> ActiveSheet.Range("B1").Select
> ActiveSheet.Paste
> ActiveSheet.Range("A1") = "Project_No"
> Windows(szThisFileName).Activate
>
> 'Copy risk data from the Register worksheet and transfer
> 'data into temporary workbook in C drive.
>
> 'Find last record in Register
> Call DetermineRange(nor)
>
> Worksheets("Register").Select
> szPETNumber = ActiveSheet.Range("A2")
> ActiveSheet.Range("C2:V" & nor).Copy
>
> 'Truncate Notes and Key Messages fields at 255 characters
> 'Worksheets("Transfer Sheet").Select
> 'szNotes = Worksheets("Stakeholder " & szStakeholder).Range("C66")
> 'szNotes = Left(szNotes, 255)
> 'szKeyMessages = Worksheets("Stakeholder " &
szStakeholder).Range("C71")
> 'szKeyMessages = Left(szKeyMessages, 255)
>
> 'Paste the copied data into the Risk Transfer workbook
> Windows(szWindowName).Activate
> ActiveSheet.Name = "Risk Transfers1"
> ActiveSheet.Range("B2").Select
> ActiveSheet.Paste
>
> 'Write in the Project Number on each row
> ActiveSheet.Range("A2:A" & nor) = szPETNumber
>
> 'Return to the Risk Register
> Windows(szThisFileName).Activate
> Application.CutCopyMode = False
>
> 'Save and close risk Transfer workbook
> Windows(szWindowName).Activate
> ActiveWorkbook.Save
> ActiveWindow.Close
> Windows(szThisFileName).Activate
>
>
> 'Protect Register worksheet
> Worksheets("Register").Select
> ActiveSheet.Protect
> Worksheets("FrontScreen").Select
> Exit Sub
>
> ir1: Response = MsgBox("You already have a risk Transfer workbook " _
> + "in your C Drive. Do you want to " _
> + "delete this existing Risk Transfer workbook " _
> + "and replace it with a new version?", vbYesNo)
> If Response = vbYes Then
> MsgBox ("Click the Transfer Data button " _
> + "again and when prompted that there is an existing " _
> + "risk Transfer file and asking if you " _
> + "wish to replace it, click Yes.")
> MsgBox ("You will have created a temporary workbook called
Book
> " _
> + "Book*.xls. You will need to delete this when you finish
the
> session.")
> GoTo ir2:
> Else
> GoTo ir2:
> End If
>
> ir2: Windows(szThisFileName).Activate
> Worksheets("Register").Select
> ActiveSheet.Protect
> Worksheets("FrontScreen").Select
> Exit Sub
> End Sub
>
>

"Tom Ogilvy" <[email protected]> wrote in message
news:[email protected]...
> What does the below have to do with your question? It appears to be
writing
> information to a new workbook, not replacing sheets in an existing
workbook.
> What actually is your question.
>
> --
> Regards,
> Tom Ogilvy
>
> "ohboy!" <[email protected]> wrote in message
> news:[email protected]...
> > Good moring all,
> >
> > I'm trying to accomplish the following:
> >
> > file1.xls
> >
> > copy worksheet1 from file1.xls
> >
> > and then insert into file2.xls without overwriting file1.xls completely.
> >
> > The reason - I have one master xls file with multiple named worksheets.
> > Each worksheet relates to another xls file and on a weekly basis I want
> the
> > master xls file's different worksheets updated so the worksheets are
> > replaced but the main master xls file is not. All I've accomplished so
> far
> > is below:
> >
> > Public Sub TransferData()
> >
> > 'Disable screen updating while the subroutine is run
> > Application.ScreenUpdating = False
> >
> > 'Unprotect all Register worksheet
> > Worksheets("Register").Select
> > ActiveSheet.Unprotect
> >
> > 'Define Variables
> > Dim szThisFileName As String
> > Dim szFileName As String
> > Dim szWindowName As String
> > Dim szNotes As String
> > Dim szPETNumber As String
> > Dim Response As Integer
> >
> > 'Set initial values
> > szThisFileName = ActiveWorkbook.Name
> > szWindowName = "Test Risk Transfer.xls"
> > szFileName = "C:\" & szWindowName
> > iRow = 1
> >
> > 'Check if user wants to continue
> > If MsgBox("This facility is only for transfering information into "
_
> > + "the BISTD Central Register repository database. " _
> > + "Are you sure you want to continue?", vbQuestion + vbYesNo) =
> vbNo
> > Then
> > Exit Sub
> > End If
> >
> > 'Check if there is any data to transfer
> > Worksheets("Register").Select
> > If ActiveSheet.Range("C2") = "" Then
> > MsgBox ("There are no risks in the Register to " _
> > + "transfer.")
> > ActiveSheet.Protect
> > Exit Sub
> > End If
> >
> > 'Create Risk Transfer workbook on C drive
> > On Error GoTo ir1:
> > Workbooks.Add
> > ChDir "C:\"
> > ActiveWorkbook.SaveAs FileName:=szFileName, FileFormat:=xlNormal, _
> > Password:="", WriteResPassword:="", ReadOnlyRecommended:=False,
_
> > CreateBackup:=False
> > Windows(szWindowName).Activate
> > Sheets.Add
> > ActiveSheet.Name = "Risk Transfers1"
> > Windows(szThisFileName).Activate
> >
> > 'Add column headings to Stakeholder Transfer workbook
> > Worksheets("Register").Select
> > ActiveSheet.Range("C1:V1").Select
> > Selection.Copy
> > Windows(szWindowName).Activate
> > Worksheets("Risk Transfers1").Select
> > ActiveSheet.Range("B1").Select
> > ActiveSheet.Paste
> > ActiveSheet.Range("A1") = "Project_No"
> > Windows(szThisFileName).Activate
> >
> > 'Copy risk data from the Register worksheet and transfer
> > 'data into temporary workbook in C drive.
> >
> > 'Find last record in Register
> > Call DetermineRange(nor)
> >
> > Worksheets("Register").Select
> > szPETNumber = ActiveSheet.Range("A2")
> > ActiveSheet.Range("C2:V" & nor).Copy
> >
> > 'Truncate Notes and Key Messages fields at 255 characters
> > 'Worksheets("Transfer Sheet").Select
> > 'szNotes = Worksheets("Stakeholder " & szStakeholder).Range("C66")
> > 'szNotes = Left(szNotes, 255)
> > 'szKeyMessages = Worksheets("Stakeholder " &
> szStakeholder).Range("C71")
> > 'szKeyMessages = Left(szKeyMessages, 255)
> >
> > 'Paste the copied data into the Risk Transfer workbook
> > Windows(szWindowName).Activate
> > ActiveSheet.Name = "Risk Transfers1"
> > ActiveSheet.Range("B2").Select
> > ActiveSheet.Paste
> >
> > 'Write in the Project Number on each row
> > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> >
> > 'Return to the Risk Register
> > Windows(szThisFileName).Activate
> > Application.CutCopyMode = False
> >
> > 'Save and close risk Transfer workbook
> > Windows(szWindowName).Activate
> > ActiveWorkbook.Save
> > ActiveWindow.Close
> > Windows(szThisFileName).Activate
> >
> >
> > 'Protect Register worksheet
> > Worksheets("Register").Select
> > ActiveSheet.Protect
> > Worksheets("FrontScreen").Select
> > Exit Sub
> >
> > ir1: Response = MsgBox("You already have a risk Transfer workbook " _
> > + "in your C Drive. Do you want to " _
> > + "delete this existing Risk Transfer workbook " _
> > + "and replace it with a new version?", vbYesNo)
> > If Response = vbYes Then
> > MsgBox ("Click the Transfer Data button " _
> > + "again and when prompted that there is an existing " _
> > + "risk Transfer file and asking if you " _
> > + "wish to replace it, click Yes.")
> > MsgBox ("You will have created a temporary workbook called
> Book
> > " _
> > + "Book*.xls. You will need to delete this when you finish
> the
> > session.")
> > GoTo ir2:
> > Else
> > GoTo ir2:
> > End If
> >
> > ir2: Windows(szThisFileName).Activate
> > Worksheets("Register").Select
> > ActiveSheet.Protect
> > Worksheets("FrontScreen").Select
> > Exit Sub
> > End Sub
> >
> >
>
Sorry for not being clear.....

As above, originally a copy of one sheet from the xls file was copied to a
newly created xls file.

Instead of that the new xls file will have been already created but I want
the vb to copy a defined worksheet across to this this file. There will be
multiple sheets each of which will be fed by different xls files

Dim bk1 as Workbook
Dim bk2 as Workbook
Dim sh1 as Worksheet
Dim sh2 as Worksheet
Dim idx as LOng
set bk1 = Workbooks("ABC.xls")
set bk2 = Workbooks("EFG.xls")
set sh1 = Bk1.Worksheets("Sheet1")
on Error Resume Next
set sh2 = bk2.worksheets(sh1.name)
On Error goto 0
if not sh2 is nothing then
idx = sh2.Index
Application.DisplayAlerts = False
sh2.delete
Application.DisplayAlerts = True
if idx > 1 then
sh1.copy after:=bk2.sheets(idx-1)
else
sh1.copy before:=bk2.Sheets(2)
end if
else
sh1.copy after:=bk2.Worksheets(bk2.Worksheets.count)
end if

The above will copy Sheet1 from ABC.xls to EFG.xls. If there is a sheet1 in
EFG.xls, it will replace it. If not, it will add it at the end.

Hopefully you can adapt a similar approach to your code.

--
Regards,
Tom Ogilvy



"ohboy!" <[email protected]> wrote in message
news:[email protected]...
>
> "Tom Ogilvy" <[email protected]> wrote in message
> news:[email protected]...
> > What does the below have to do with your question? It appears to be
> writing
> > information to a new workbook, not replacing sheets in an existing
> workbook.
> > What actually is your question.
> >
> > --
> > Regards,
> > Tom Ogilvy
> >
> > "ohboy!" <[email protected]> wrote in message
> > news:[email protected]...
> > > Good moring all,
> > >
> > > I'm trying to accomplish the following:
> > >
> > > file1.xls
> > >
> > > copy worksheet1 from file1.xls
> > >
> > > and then insert into file2.xls without overwriting file1.xls
completely.
> > >
> > > The reason - I have one master xls file with multiple named
worksheets.
> > > Each worksheet relates to another xls file and on a weekly basis I
want
> > the
> > > master xls file's different worksheets updated so the worksheets are
> > > replaced but the main master xls file is not. All I've accomplished
so
> > far
> > > is below:
> > >
> > > Public Sub TransferData()
> > >
> > > 'Disable screen updating while the subroutine is run
> > > Application.ScreenUpdating = False
> > >
> > > 'Unprotect all Register worksheet
> > > Worksheets("Register").Select
> > > ActiveSheet.Unprotect
> > >
> > > 'Define Variables
> > > Dim szThisFileName As String
> > > Dim szFileName As String
> > > Dim szWindowName As String
> > > Dim szNotes As String
> > > Dim szPETNumber As String
> > > Dim Response As Integer
> > >
> > > 'Set initial values
> > > szThisFileName = ActiveWorkbook.Name
> > > szWindowName = "Test Risk Transfer.xls"
> > > szFileName = "C:\" & szWindowName
> > > iRow = 1
> > >
> > > 'Check if user wants to continue
> > > If MsgBox("This facility is only for transfering information into
"
> _
> > > + "the BISTD Central Register repository database. " _
> > > + "Are you sure you want to continue?", vbQuestion + vbYesNo)
=
> > vbNo
> > > Then
> > > Exit Sub
> > > End If
> > >
> > > 'Check if there is any data to transfer
> > > Worksheets("Register").Select
> > > If ActiveSheet.Range("C2") = "" Then
> > > MsgBox ("There are no risks in the Register to " _
> > > + "transfer.")
> > > ActiveSheet.Protect
> > > Exit Sub
> > > End If
> > >
> > > 'Create Risk Transfer workbook on C drive
> > > On Error GoTo ir1:
> > > Workbooks.Add
> > > ChDir "C:\"
> > > ActiveWorkbook.SaveAs FileName:=szFileName, FileFormat:=xlNormal,
_
> > > Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False,
> _
> > > CreateBackup:=False
> > > Windows(szWindowName).Activate
> > > Sheets.Add
> > > ActiveSheet.Name = "Risk Transfers1"
> > > Windows(szThisFileName).Activate
> > >
> > > 'Add column headings to Stakeholder Transfer workbook
> > > Worksheets("Register").Select
> > > ActiveSheet.Range("C1:V1").Select
> > > Selection.Copy
> > > Windows(szWindowName).Activate
> > > Worksheets("Risk Transfers1").Select
> > > ActiveSheet.Range("B1").Select
> > > ActiveSheet.Paste
> > > ActiveSheet.Range("A1") = "Project_No"
> > > Windows(szThisFileName).Activate
> > >
> > > 'Copy risk data from the Register worksheet and transfer
> > > 'data into temporary workbook in C drive.
> > >
> > > 'Find last record in Register
> > > Call DetermineRange(nor)
> > >
> > > Worksheets("Register").Select
> > > szPETNumber = ActiveSheet.Range("A2")
> > > ActiveSheet.Range("C2:V" & nor).Copy
> > >
> > > 'Truncate Notes and Key Messages fields at 255 characters
> > > 'Worksheets("Transfer Sheet").Select
> > > 'szNotes = Worksheets("Stakeholder " & szStakeholder).Range("C66")
> > > 'szNotes = Left(szNotes, 255)
> > > 'szKeyMessages = Worksheets("Stakeholder " &
> > szStakeholder).Range("C71")
> > > 'szKeyMessages = Left(szKeyMessages, 255)
> > >
> > > 'Paste the copied data into the Risk Transfer workbook
> > > Windows(szWindowName).Activate
> > > ActiveSheet.Name = "Risk Transfers1"
> > > ActiveSheet.Range("B2").Select
> > > ActiveSheet.Paste
> > >
> > > 'Write in the Project Number on each row
> > > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> > >
> > > 'Return to the Risk Register
> > > Windows(szThisFileName).Activate
> > > Application.CutCopyMode = False
> > >
> > > 'Save and close risk Transfer workbook
> > > Windows(szWindowName).Activate
> > > ActiveWorkbook.Save
> > > ActiveWindow.Close
> > > Windows(szThisFileName).Activate
> > >
> > >
> > > 'Protect Register worksheet
> > > Worksheets("Register").Select
> > > ActiveSheet.Protect
> > > Worksheets("FrontScreen").Select
> > > Exit Sub
> > >
> > > ir1: Response = MsgBox("You already have a risk Transfer workbook "
_
> > > + "in your C Drive. Do you want to " _
> > > + "delete this existing Risk Transfer workbook " _
> > > + "and replace it with a new version?", vbYesNo)
> > > If Response = vbYes Then
> > > MsgBox ("Click the Transfer Data button " _
> > > + "again and when prompted that there is an existing " _
> > > + "risk Transfer file and asking if you " _
> > > + "wish to replace it, click Yes.")
> > > MsgBox ("You will have created a temporary workbook called
> > Book
> > > " _
> > > + "Book*.xls. You will need to delete this when you
finish
> > the
> > > session.")
> > > GoTo ir2:
> > > Else
> > > GoTo ir2:
> > > End If
> > >
> > > ir2: Windows(szThisFileName).Activate
> > > Worksheets("Register").Select
> > > ActiveSheet.Protect
> > > Worksheets("FrontScreen").Select
> > > Exit Sub
> > > End Sub
> > >
> > >
> >
> Sorry for not being clear.....
>
> As above, originally a copy of one sheet from the xls file was copied to a
> newly created xls file.
>
> Instead of that the new xls file will have been already created but I want
> the vb to copy a defined worksheet across to this this file. There will
be
> multiple sheets each of which will be fed by different xls files
>
>

Thanks Tom...I'll give it ago later and come back....sorry for not being
clear in the first place...been scripting a risk and issue register for
days!

"Tom Ogilvy" <[email protected]> wrote in message
news:[email protected]...
> Dim bk1 as Workbook
> Dim bk2 as Workbook
> Dim sh1 as Worksheet
> Dim sh2 as Worksheet
> Dim idx as LOng
> set bk1 = Workbooks("ABC.xls")
> set bk2 = Workbooks("EFG.xls")
> set sh1 = Bk1.Worksheets("Sheet1")
> on Error Resume Next
> set sh2 = bk2.worksheets(sh1.name)
> On Error goto 0
> if not sh2 is nothing then
> idx = sh2.Index
> Application.DisplayAlerts = False
> sh2.delete
> Application.DisplayAlerts = True
> if idx > 1 then
> sh1.copy after:=bk2.sheets(idx-1)
> else
> sh1.copy before:=bk2.Sheets(2)
> end if
> else
> sh1.copy after:=bk2.Worksheets(bk2.Worksheets.count)
> end if
>
> The above will copy Sheet1 from ABC.xls to EFG.xls. If there is a sheet1
in
> EFG.xls, it will replace it. If not, it will add it at the end.
>
> Hopefully you can adapt a similar approach to your code.
>
> --
> Regards,
> Tom Ogilvy
>
>
>
> "ohboy!" <[email protected]> wrote in message
> news:[email protected]...
> >
> > "Tom Ogilvy" <[email protected]> wrote in message
> > news:[email protected]...
> > > What does the below have to do with your question? It appears to be
> > writing
> > > information to a new workbook, not replacing sheets in an existing
> > workbook.
> > > What actually is your question.
> > >
> > > --
> > > Regards,
> > > Tom Ogilvy
> > >
> > > "ohboy!" <[email protected]> wrote in message
> > > news:[email protected]...
> > > > Good moring all,
> > > >
> > > > I'm trying to accomplish the following:
> > > >
> > > > file1.xls
> > > >
> > > > copy worksheet1 from file1.xls
> > > >
> > > > and then insert into file2.xls without overwriting file1.xls
> completely.
> > > >
> > > > The reason - I have one master xls file with multiple named
> worksheets.
> > > > Each worksheet relates to another xls file and on a weekly basis I
> want
> > > the
> > > > master xls file's different worksheets updated so the worksheets are
> > > > replaced but the main master xls file is not. All I've accomplished
> so
> > > far
> > > > is below:
> > > >
> > > > Public Sub TransferData()
> > > >
> > > > 'Disable screen updating while the subroutine is run
> > > > Application.ScreenUpdating = False
> > > >
> > > > 'Unprotect all Register worksheet
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Unprotect
> > > >
> > > > 'Define Variables
> > > > Dim szThisFileName As String
> > > > Dim szFileName As String
> > > > Dim szWindowName As String
> > > > Dim szNotes As String
> > > > Dim szPETNumber As String
> > > > Dim Response As Integer
> > > >
> > > > 'Set initial values
> > > > szThisFileName = ActiveWorkbook.Name
> > > > szWindowName = "Test Risk Transfer.xls"
> > > > szFileName = "C:\" & szWindowName
> > > > iRow = 1
> > > >
> > > > 'Check if user wants to continue
> > > > If MsgBox("This facility is only for transfering information
into
> "
> > _
> > > > + "the BISTD Central Register repository database. " _
> > > > + "Are you sure you want to continue?", vbQuestion +
vbYesNo)
> =
> > > vbNo
> > > > Then
> > > > Exit Sub
> > > > End If
> > > >
> > > > 'Check if there is any data to transfer
> > > > Worksheets("Register").Select
> > > > If ActiveSheet.Range("C2") = "" Then
> > > > MsgBox ("There are no risks in the Register to " _
> > > > + "transfer.")
> > > > ActiveSheet.Protect
> > > > Exit Sub
> > > > End If
> > > >
> > > > 'Create Risk Transfer workbook on C drive
> > > > On Error GoTo ir1:
> > > > Workbooks.Add
> > > > ChDir "C:\"
> > > > ActiveWorkbook.SaveAs FileName:=szFileName,
FileFormat:=xlNormal,
> _
> > > > Password:="", WriteResPassword:="",
> ReadOnlyRecommended:=False,
> > _
> > > > CreateBackup:=False
> > > > Windows(szWindowName).Activate
> > > > Sheets.Add
> > > > ActiveSheet.Name = "Risk Transfers1"
> > > > Windows(szThisFileName).Activate
> > > >
> > > > 'Add column headings to Stakeholder Transfer workbook
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Range("C1:V1").Select
> > > > Selection.Copy
> > > > Windows(szWindowName).Activate
> > > > Worksheets("Risk Transfers1").Select
> > > > ActiveSheet.Range("B1").Select
> > > > ActiveSheet.Paste
> > > > ActiveSheet.Range("A1") = "Project_No"
> > > > Windows(szThisFileName).Activate
> > > >
> > > > 'Copy risk data from the Register worksheet and transfer
> > > > 'data into temporary workbook in C drive.
> > > >
> > > > 'Find last record in Register
> > > > Call DetermineRange(nor)
> > > >
> > > > Worksheets("Register").Select
> > > > szPETNumber = ActiveSheet.Range("A2")
> > > > ActiveSheet.Range("C2:V" & nor).Copy
> > > >
> > > > 'Truncate Notes and Key Messages fields at 255 characters
> > > > 'Worksheets("Transfer Sheet").Select
> > > > 'szNotes = Worksheets("Stakeholder " &
szStakeholder).Range("C66")
> > > > 'szNotes = Left(szNotes, 255)
> > > > 'szKeyMessages = Worksheets("Stakeholder " &
> > > szStakeholder).Range("C71")
> > > > 'szKeyMessages = Left(szKeyMessages, 255)
> > > >
> > > > 'Paste the copied data into the Risk Transfer workbook
> > > > Windows(szWindowName).Activate
> > > > ActiveSheet.Name = "Risk Transfers1"
> > > > ActiveSheet.Range("B2").Select
> > > > ActiveSheet.Paste
> > > >
> > > > 'Write in the Project Number on each row
> > > > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> > > >
> > > > 'Return to the Risk Register
> > > > Windows(szThisFileName).Activate
> > > > Application.CutCopyMode = False
> > > >
> > > > 'Save and close risk Transfer workbook
> > > > Windows(szWindowName).Activate
> > > > ActiveWorkbook.Save
> > > > ActiveWindow.Close
> > > > Windows(szThisFileName).Activate
> > > >
> > > >
> > > > 'Protect Register worksheet
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Protect
> > > > Worksheets("FrontScreen").Select
> > > > Exit Sub
> > > >
> > > > ir1: Response = MsgBox("You already have a risk Transfer workbook
"
> _
> > > > + "in your C Drive. Do you want to " _
> > > > + "delete this existing Risk Transfer workbook " _
> > > > + "and replace it with a new version?", vbYesNo)
> > > > If Response = vbYes Then
> > > > MsgBox ("Click the Transfer Data button " _
> > > > + "again and when prompted that there is an existing " _
> > > > + "risk Transfer file and asking if you " _
> > > > + "wish to replace it, click Yes.")
> > > > MsgBox ("You will have created a temporary workbook
called
> > > Book
> > > > " _
> > > > + "Book*.xls. You will need to delete this when you
> finish
> > > the
> > > > session.")
> > > > GoTo ir2:
> > > > Else
> > > > GoTo ir2:
> > > > End If
> > > >
> > > > ir2: Windows(szThisFileName).Activate
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Protect
> > > > Worksheets("FrontScreen").Select
> > > > Exit Sub
> > > > End Sub
> > > >
> > > >
> > >
> > Sorry for not being clear.....
> >
> > As above, originally a copy of one sheet from the xls file was copied to
a
> > newly created xls file.
> >
> > Instead of that the new xls file will have been already created but I
want
> > the vb to copy a defined worksheet across to this this file. There will
> be
> > multiple sheets each of which will be fed by different xls files
> >
> >
>
>

Hi Tom,

Have tried the following but to no avail...

Public Sub TransferData()

Worksheets("Register").Select
ActiveSheet.Unprotect
Dim bk1 As Workbook
Dim bk2 As Workbook
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim idx As Long
Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of range
Set bk2 = Workbooks("c:\test.xls")
Set sh1 = bk1.Worksheets("Register")
On Error Resume Next
Set sh2 = bk2.Worksheets("RegisterCopy")
On Error GoTo 0
If Not sh2 Is Nothing Then
idx = sh2.Index
Application.DisplayAlerts = False
sh2.Delete
Application.DisplayAlerts = True
If idx > 1 Then
sh1.Copy after:=bk2.Sheets(idx - 1)
Else
sh1.Copy before:=bk2.Sheets(2)
End If
Else
sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
End If
End Sub

Definately alot simpler than my first approach...


"Tom Ogilvy" <[email protected]> wrote in message
news:[email protected]...
> Dim bk1 as Workbook
> Dim bk2 as Workbook
> Dim sh1 as Worksheet
> Dim sh2 as Worksheet
> Dim idx as LOng
> set bk1 = Workbooks("ABC.xls")
> set bk2 = Workbooks("EFG.xls")
> set sh1 = Bk1.Worksheets("Sheet1")
> on Error Resume Next
> set sh2 = bk2.worksheets(sh1.name)
> On Error goto 0
> if not sh2 is nothing then
> idx = sh2.Index
> Application.DisplayAlerts = False
> sh2.delete
> Application.DisplayAlerts = True
> if idx > 1 then
> sh1.copy after:=bk2.sheets(idx-1)
> else
> sh1.copy before:=bk2.Sheets(2)
> end if
> else
> sh1.copy after:=bk2.Worksheets(bk2.Worksheets.count)
> end if
>
> The above will copy Sheet1 from ABC.xls to EFG.xls. If there is a sheet1
in
> EFG.xls, it will replace it. If not, it will add it at the end.
>
> Hopefully you can adapt a similar approach to your code.
>
> --
> Regards,
> Tom Ogilvy
>
>
>
> "ohboy!" <[email protected]> wrote in message
> news:[email protected]...
> >
> > "Tom Ogilvy" <[email protected]> wrote in message
> > news:[email protected]...
> > > What does the below have to do with your question? It appears to be
> > writing
> > > information to a new workbook, not replacing sheets in an existing
> > workbook.
> > > What actually is your question.
> > >
> > > --
> > > Regards,
> > > Tom Ogilvy
> > >
> > > "ohboy!" <[email protected]> wrote in message
> > > news:[email protected]...
> > > > Good moring all,
> > > >
> > > > I'm trying to accomplish the following:
> > > >
> > > > file1.xls
> > > >
> > > > copy worksheet1 from file1.xls
> > > >
> > > > and then insert into file2.xls without overwriting file1.xls
> completely.
> > > >
> > > > The reason - I have one master xls file with multiple named
> worksheets.
> > > > Each worksheet relates to another xls file and on a weekly basis I
> want
> > > the
> > > > master xls file's different worksheets updated so the worksheets are
> > > > replaced but the main master xls file is not. All I've accomplished
> so
> > > far
> > > > is below:
> > > >
> > > > Public Sub TransferData()
> > > >
> > > > 'Disable screen updating while the subroutine is run
> > > > Application.ScreenUpdating = False
> > > >
> > > > 'Unprotect all Register worksheet
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Unprotect
> > > >
> > > > 'Define Variables
> > > > Dim szThisFileName As String
> > > > Dim szFileName As String
> > > > Dim szWindowName As String
> > > > Dim szNotes As String
> > > > Dim szPETNumber As String
> > > > Dim Response As Integer
> > > >
> > > > 'Set initial values
> > > > szThisFileName = ActiveWorkbook.Name
> > > > szWindowName = "Test Risk Transfer.xls"
> > > > szFileName = "C:\" & szWindowName
> > > > iRow = 1
> > > >
> > > > 'Check if user wants to continue
> > > > If MsgBox("This facility is only for transfering information
into
> "
> > _
> > > > + "the BISTD Central Register repository database. " _
> > > > + "Are you sure you want to continue?", vbQuestion +
vbYesNo)
> =
> > > vbNo
> > > > Then
> > > > Exit Sub
> > > > End If
> > > >
> > > > 'Check if there is any data to transfer
> > > > Worksheets("Register").Select
> > > > If ActiveSheet.Range("C2") = "" Then
> > > > MsgBox ("There are no risks in the Register to " _
> > > > + "transfer.")
> > > > ActiveSheet.Protect
> > > > Exit Sub
> > > > End If
> > > >
> > > > 'Create Risk Transfer workbook on C drive
> > > > On Error GoTo ir1:
> > > > Workbooks.Add
> > > > ChDir "C:\"
> > > > ActiveWorkbook.SaveAs FileName:=szFileName,
FileFormat:=xlNormal,
> _
> > > > Password:="", WriteResPassword:="",
> ReadOnlyRecommended:=False,
> > _
> > > > CreateBackup:=False
> > > > Windows(szWindowName).Activate
> > > > Sheets.Add
> > > > ActiveSheet.Name = "Risk Transfers1"
> > > > Windows(szThisFileName).Activate
> > > >
> > > > 'Add column headings to Stakeholder Transfer workbook
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Range("C1:V1").Select
> > > > Selection.Copy
> > > > Windows(szWindowName).Activate
> > > > Worksheets("Risk Transfers1").Select
> > > > ActiveSheet.Range("B1").Select
> > > > ActiveSheet.Paste
> > > > ActiveSheet.Range("A1") = "Project_No"
> > > > Windows(szThisFileName).Activate
> > > >
> > > > 'Copy risk data from the Register worksheet and transfer
> > > > 'data into temporary workbook in C drive.
> > > >
> > > > 'Find last record in Register
> > > > Call DetermineRange(nor)
> > > >
> > > > Worksheets("Register").Select
> > > > szPETNumber = ActiveSheet.Range("A2")
> > > > ActiveSheet.Range("C2:V" & nor).Copy
> > > >
> > > > 'Truncate Notes and Key Messages fields at 255 characters
> > > > 'Worksheets("Transfer Sheet").Select
> > > > 'szNotes = Worksheets("Stakeholder " &
szStakeholder).Range("C66")
> > > > 'szNotes = Left(szNotes, 255)
> > > > 'szKeyMessages = Worksheets("Stakeholder " &
> > > szStakeholder).Range("C71")
> > > > 'szKeyMessages = Left(szKeyMessages, 255)
> > > >
> > > > 'Paste the copied data into the Risk Transfer workbook
> > > > Windows(szWindowName).Activate
> > > > ActiveSheet.Name = "Risk Transfers1"
> > > > ActiveSheet.Range("B2").Select
> > > > ActiveSheet.Paste
> > > >
> > > > 'Write in the Project Number on each row
> > > > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> > > >
> > > > 'Return to the Risk Register
> > > > Windows(szThisFileName).Activate
> > > > Application.CutCopyMode = False
> > > >
> > > > 'Save and close risk Transfer workbook
> > > > Windows(szWindowName).Activate
> > > > ActiveWorkbook.Save
> > > > ActiveWindow.Close
> > > > Windows(szThisFileName).Activate
> > > >
> > > >
> > > > 'Protect Register worksheet
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Protect
> > > > Worksheets("FrontScreen").Select
> > > > Exit Sub
> > > >
> > > > ir1: Response = MsgBox("You already have a risk Transfer workbook
"
> _
> > > > + "in your C Drive. Do you want to " _
> > > > + "delete this existing Risk Transfer workbook " _
> > > > + "and replace it with a new version?", vbYesNo)
> > > > If Response = vbYes Then
> > > > MsgBox ("Click the Transfer Data button " _
> > > > + "again and when prompted that there is an existing " _
> > > > + "risk Transfer file and asking if you " _
> > > > + "wish to replace it, click Yes.")
> > > > MsgBox ("You will have created a temporary workbook
called
> > > Book
> > > > " _
> > > > + "Book*.xls. You will need to delete this when you
> finish
> > > the
> > > > session.")
> > > > GoTo ir2:
> > > > Else
> > > > GoTo ir2:
> > > > End If
> > > >
> > > > ir2: Windows(szThisFileName).Activate
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Protect
> > > > Worksheets("FrontScreen").Select
> > > > Exit Sub
> > > > End Sub
> > > >
> > > >
> > >
> > Sorry for not being clear.....
> >
> > As above, originally a copy of one sheet from the xls file was copied to
a
> > newly created xls file.
> >
> > Instead of that the new xls file will have been already created but I
want
> > the vb to copy a defined worksheet across to this this file. There will
> be
> > multiple sheets each of which will be fed by different xls files
> >
> >
>
>

Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of range
Set bk2 = Workbooks("c:\test.xls")

if the workbooks are already open, then don't use the path, just use the
workbook name. Otherwise you need to open them

set Bk1 = Workbooks("Test1.xls")

or

set Bk1 = Workbooks.Open("C:\Text1.xls")

Also, If you want sheet register to replace sheet registercopy, you would
modify the code like this

Assumes both workbooks are open and the activeworkbook is the workbook
containing the data to be copied (since you activate a sheet named
register).

Public Sub TransferData()

Worksheets("Register").Select
ActiveSheet.Unprotect
Dim bk1 As Workbook
Dim bk2 As Workbook
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim idx As Long
Set bk1 = ActiveWorkbook
Set bk2 = Workbooks("test.xls")
Set sh1 = bk1.Worksheets("Register")
On Error Resume Next
Set sh2 = bk2.Worksheets("RegisterCopy")
On Error GoTo 0
If Not sh2 Is Nothing Then
idx = sh2.Index
Application.DisplayAlerts = False
sh2.Delete
Application.DisplayAlerts = True
If idx > 1 Then
sh1.Copy after:=bk2.Sheets(idx - 1)
Else
sh1.Copy before:=bk2.Sheets(2)
End If
Else
sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
End If
Activesheet.Name = "RegisterCopy"
End Sub

--
Regards,
Tom Ogilvy




--
Regards,
Tom Ogilvy

"ohboy!" <[email protected]> wrote in message
news:[email protected]...
> Hi Tom,
>
> Have tried the following but to no avail...
>
> Public Sub TransferData()
>
> Worksheets("Register").Select
> ActiveSheet.Unprotect
> Dim bk1 As Workbook
> Dim bk2 As Workbook
> Dim sh1 As Worksheet
> Dim sh2 As Worksheet
> Dim idx As Long
> Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of range
> Set bk2 = Workbooks("c:\test.xls")
> Set sh1 = bk1.Worksheets("Register")
> On Error Resume Next
> Set sh2 = bk2.Worksheets("RegisterCopy")
> On Error GoTo 0
> If Not sh2 Is Nothing Then
> idx = sh2.Index
> Application.DisplayAlerts = False
> sh2.Delete
> Application.DisplayAlerts = True
> If idx > 1 Then
> sh1.Copy after:=bk2.Sheets(idx - 1)
> Else
> sh1.Copy before:=bk2.Sheets(2)
> End If
> Else
> sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> End If
> End Sub
>
> Definately alot simpler than my first approach...
>
>
> "Tom Ogilvy" <[email protected]> wrote in message
> news:[email protected]...
> > Dim bk1 as Workbook
> > Dim bk2 as Workbook
> > Dim sh1 as Worksheet
> > Dim sh2 as Worksheet
> > Dim idx as LOng
> > set bk1 = Workbooks("ABC.xls")
> > set bk2 = Workbooks("EFG.xls")
> > set sh1 = Bk1.Worksheets("Sheet1")
> > on Error Resume Next
> > set sh2 = bk2.worksheets(sh1.name)
> > On Error goto 0
> > if not sh2 is nothing then
> > idx = sh2.Index
> > Application.DisplayAlerts = False
> > sh2.delete
> > Application.DisplayAlerts = True
> > if idx > 1 then
> > sh1.copy after:=bk2.sheets(idx-1)
> > else
> > sh1.copy before:=bk2.Sheets(2)
> > end if
> > else
> > sh1.copy after:=bk2.Worksheets(bk2.Worksheets.count)
> > end if
> >
> > The above will copy Sheet1 from ABC.xls to EFG.xls. If there is a
sheet1
> in
> > EFG.xls, it will replace it. If not, it will add it at the end.
> >
> > Hopefully you can adapt a similar approach to your code.
> >
> > --
> > Regards,
> > Tom Ogilvy
> >
> >
> >
> > "ohboy!" <[email protected]> wrote in message
> > news:[email protected]...
> > >
> > > "Tom Ogilvy" <[email protected]> wrote in message
> > > news:[email protected]...
> > > > What does the below have to do with your question? It appears to be
> > > writing
> > > > information to a new workbook, not replacing sheets in an existing
> > > workbook.
> > > > What actually is your question.
> > > >
> > > > --
> > > > Regards,
> > > > Tom Ogilvy
> > > >
> > > > "ohboy!" <[email protected]> wrote in message
> > > > news:[email protected]...
> > > > > Good moring all,
> > > > >
> > > > > I'm trying to accomplish the following:
> > > > >
> > > > > file1.xls
> > > > >
> > > > > copy worksheet1 from file1.xls
> > > > >
> > > > > and then insert into file2.xls without overwriting file1.xls
> > completely.
> > > > >
> > > > > The reason - I have one master xls file with multiple named
> > worksheets.
> > > > > Each worksheet relates to another xls file and on a weekly basis I
> > want
> > > > the
> > > > > master xls file's different worksheets updated so the worksheets
are
> > > > > replaced but the main master xls file is not. All I've
accomplished
> > so
> > > > far
> > > > > is below:
> > > > >
> > > > > Public Sub TransferData()
> > > > >
> > > > > 'Disable screen updating while the subroutine is run
> > > > > Application.ScreenUpdating = False
> > > > >
> > > > > 'Unprotect all Register worksheet
> > > > > Worksheets("Register").Select
> > > > > ActiveSheet.Unprotect
> > > > >
> > > > > 'Define Variables
> > > > > Dim szThisFileName As String
> > > > > Dim szFileName As String
> > > > > Dim szWindowName As String
> > > > > Dim szNotes As String
> > > > > Dim szPETNumber As String
> > > > > Dim Response As Integer
> > > > >
> > > > > 'Set initial values
> > > > > szThisFileName = ActiveWorkbook.Name
> > > > > szWindowName = "Test Risk Transfer.xls"
> > > > > szFileName = "C:\" & szWindowName
> > > > > iRow = 1
> > > > >
> > > > > 'Check if user wants to continue
> > > > > If MsgBox("This facility is only for transfering information
> into
> > "
> > > _
> > > > > + "the BISTD Central Register repository database. " _
> > > > > + "Are you sure you want to continue?", vbQuestion +
> vbYesNo)
> > =
> > > > vbNo
> > > > > Then
> > > > > Exit Sub
> > > > > End If
> > > > >
> > > > > 'Check if there is any data to transfer
> > > > > Worksheets("Register").Select
> > > > > If ActiveSheet.Range("C2") = "" Then
> > > > > MsgBox ("There are no risks in the Register to " _
> > > > > + "transfer.")
> > > > > ActiveSheet.Protect
> > > > > Exit Sub
> > > > > End If
> > > > >
> > > > > 'Create Risk Transfer workbook on C drive
> > > > > On Error GoTo ir1:
> > > > > Workbooks.Add
> > > > > ChDir "C:\"
> > > > > ActiveWorkbook.SaveAs FileName:=szFileName,
> FileFormat:=xlNormal,
> > _
> > > > > Password:="", WriteResPassword:="",
> > ReadOnlyRecommended:=False,
> > > _
> > > > > CreateBackup:=False
> > > > > Windows(szWindowName).Activate
> > > > > Sheets.Add
> > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > Windows(szThisFileName).Activate
> > > > >
> > > > > 'Add column headings to Stakeholder Transfer workbook
> > > > > Worksheets("Register").Select
> > > > > ActiveSheet.Range("C1:V1").Select
> > > > > Selection.Copy
> > > > > Windows(szWindowName).Activate
> > > > > Worksheets("Risk Transfers1").Select
> > > > > ActiveSheet.Range("B1").Select
> > > > > ActiveSheet.Paste
> > > > > ActiveSheet.Range("A1") = "Project_No"
> > > > > Windows(szThisFileName).Activate
> > > > >
> > > > > 'Copy risk data from the Register worksheet and transfer
> > > > > 'data into temporary workbook in C drive.
> > > > >
> > > > > 'Find last record in Register
> > > > > Call DetermineRange(nor)
> > > > >
> > > > > Worksheets("Register").Select
> > > > > szPETNumber = ActiveSheet.Range("A2")
> > > > > ActiveSheet.Range("C2:V" & nor).Copy
> > > > >
> > > > > 'Truncate Notes and Key Messages fields at 255 characters
> > > > > 'Worksheets("Transfer Sheet").Select
> > > > > 'szNotes = Worksheets("Stakeholder " &
> szStakeholder).Range("C66")
> > > > > 'szNotes = Left(szNotes, 255)
> > > > > 'szKeyMessages = Worksheets("Stakeholder " &
> > > > szStakeholder).Range("C71")
> > > > > 'szKeyMessages = Left(szKeyMessages, 255)
> > > > >
> > > > > 'Paste the copied data into the Risk Transfer workbook
> > > > > Windows(szWindowName).Activate
> > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > ActiveSheet.Range("B2").Select
> > > > > ActiveSheet.Paste
> > > > >
> > > > > 'Write in the Project Number on each row
> > > > > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> > > > >
> > > > > 'Return to the Risk Register
> > > > > Windows(szThisFileName).Activate
> > > > > Application.CutCopyMode = False
> > > > >
> > > > > 'Save and close risk Transfer workbook
> > > > > Windows(szWindowName).Activate
> > > > > ActiveWorkbook.Save
> > > > > ActiveWindow.Close
> > > > > Windows(szThisFileName).Activate
> > > > >
> > > > >
> > > > > 'Protect Register worksheet
> > > > > Worksheets("Register").Select
> > > > > ActiveSheet.Protect
> > > > > Worksheets("FrontScreen").Select
> > > > > Exit Sub
> > > > >
> > > > > ir1: Response = MsgBox("You already have a risk Transfer
workbook
> "
> > _
> > > > > + "in your C Drive. Do you want to " _
> > > > > + "delete this existing Risk Transfer workbook " _
> > > > > + "and replace it with a new version?", vbYesNo)
> > > > > If Response = vbYes Then
> > > > > MsgBox ("Click the Transfer Data button " _
> > > > > + "again and when prompted that there is an existing "
_
> > > > > + "risk Transfer file and asking if you " _
> > > > > + "wish to replace it, click Yes.")
> > > > > MsgBox ("You will have created a temporary workbook
> called
> > > > Book
> > > > > " _
> > > > > + "Book*.xls. You will need to delete this when you
> > finish
> > > > the
> > > > > session.")
> > > > > GoTo ir2:
> > > > > Else
> > > > > GoTo ir2:
> > > > > End If
> > > > >
> > > > > ir2: Windows(szThisFileName).Activate
> > > > > Worksheets("Register").Select
> > > > > ActiveSheet.Protect
> > > > > Worksheets("FrontScreen").Select
> > > > > Exit Sub
> > > > > End Sub
> > > > >
> > > > >
> > > >
> > > Sorry for not being clear.....
> > >
> > > As above, originally a copy of one sheet from the xls file was copied
to
> a
> > > newly created xls file.
> > >
> > > Instead of that the new xls file will have been already created but I
> want
> > > the vb to copy a defined worksheet across to this this file. There
will
> > be
> > > multiple sheets each of which will be fed by different xls files
> > >
> > >
> >
> >
>
>

Tom - many thanks that works! Just to verge on being cheeky, how do I get
the receiving workbook (RegisterCopy) to close after transfer?


"Tom Ogilvy" <[email protected]> wrote in message
news:[email protected]...
> Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of range
> Set bk2 = Workbooks("c:\test.xls")
>
> if the workbooks are already open, then don't use the path, just use the
> workbook name. Otherwise you need to open them
>
> set Bk1 = Workbooks("Test1.xls")
>
> or
>
> set Bk1 = Workbooks.Open("C:\Text1.xls")
>
> Also, If you want sheet register to replace sheet registercopy, you would
> modify the code like this
>
> Assumes both workbooks are open and the activeworkbook is the workbook
> containing the data to be copied (since you activate a sheet named
> register).
>
> Public Sub TransferData()
>
> Worksheets("Register").Select
> ActiveSheet.Unprotect
> Dim bk1 As Workbook
> Dim bk2 As Workbook
> Dim sh1 As Worksheet
> Dim sh2 As Worksheet
> Dim idx As Long
> Set bk1 = ActiveWorkbook
> Set bk2 = Workbooks("test.xls")
> Set sh1 = bk1.Worksheets("Register")
> On Error Resume Next
> Set sh2 = bk2.Worksheets("RegisterCopy")
> On Error GoTo 0
> If Not sh2 Is Nothing Then
> idx = sh2.Index
> Application.DisplayAlerts = False
> sh2.Delete
> Application.DisplayAlerts = True
> If idx > 1 Then
> sh1.Copy after:=bk2.Sheets(idx - 1)
> Else
> sh1.Copy before:=bk2.Sheets(2)
> End If
> Else
> sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> End If
> Activesheet.Name = "RegisterCopy"
> End Sub
>
> --
> Regards,
> Tom Ogilvy
>
>
>
>
> --
> Regards,
> Tom Ogilvy
>
> "ohboy!" <[email protected]> wrote in message
> news:[email protected]...
> > Hi Tom,
> >
> > Have tried the following but to no avail...
> >
> > Public Sub TransferData()
> >
> > Worksheets("Register").Select
> > ActiveSheet.Unprotect
> > Dim bk1 As Workbook
> > Dim bk2 As Workbook
> > Dim sh1 As Worksheet
> > Dim sh2 As Worksheet
> > Dim idx As Long
> > Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of range
> > Set bk2 = Workbooks("c:\test.xls")
> > Set sh1 = bk1.Worksheets("Register")
> > On Error Resume Next
> > Set sh2 = bk2.Worksheets("RegisterCopy")
> > On Error GoTo 0
> > If Not sh2 Is Nothing Then
> > idx = sh2.Index
> > Application.DisplayAlerts = False
> > sh2.Delete
> > Application.DisplayAlerts = True
> > If idx > 1 Then
> > sh1.Copy after:=bk2.Sheets(idx - 1)
> > Else
> > sh1.Copy before:=bk2.Sheets(2)
> > End If
> > Else
> > sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> > End If
> > End Sub
> >
> > Definately alot simpler than my first approach...
> >
> >
> > "Tom Ogilvy" <[email protected]> wrote in message
> > news:[email protected]...
> > > Dim bk1 as Workbook
> > > Dim bk2 as Workbook
> > > Dim sh1 as Worksheet
> > > Dim sh2 as Worksheet
> > > Dim idx as LOng
> > > set bk1 = Workbooks("ABC.xls")
> > > set bk2 = Workbooks("EFG.xls")
> > > set sh1 = Bk1.Worksheets("Sheet1")
> > > on Error Resume Next
> > > set sh2 = bk2.worksheets(sh1.name)
> > > On Error goto 0
> > > if not sh2 is nothing then
> > > idx = sh2.Index
> > > Application.DisplayAlerts = False
> > > sh2.delete
> > > Application.DisplayAlerts = True
> > > if idx > 1 then
> > > sh1.copy after:=bk2.sheets(idx-1)
> > > else
> > > sh1.copy before:=bk2.Sheets(2)
> > > end if
> > > else
> > > sh1.copy after:=bk2.Worksheets(bk2.Worksheets.count)
> > > end if
> > >
> > > The above will copy Sheet1 from ABC.xls to EFG.xls. If there is a
> sheet1
> > in
> > > EFG.xls, it will replace it. If not, it will add it at the end.
> > >
> > > Hopefully you can adapt a similar approach to your code.
> > >
> > > --
> > > Regards,
> > > Tom Ogilvy
> > >
> > >
> > >
> > > "ohboy!" <[email protected]> wrote in message
> > > news:[email protected]...
> > > >
> > > > "Tom Ogilvy" <[email protected]> wrote in message
> > > > news:[email protected]...
> > > > > What does the below have to do with your question? It appears to
be
> > > > writing
> > > > > information to a new workbook, not replacing sheets in an existing
> > > > workbook.
> > > > > What actually is your question.
> > > > >
> > > > > --
> > > > > Regards,
> > > > > Tom Ogilvy
> > > > >
> > > > > "ohboy!" <[email protected]> wrote in message
> > > > > news:[email protected]...
> > > > > > Good moring all,
> > > > > >
> > > > > > I'm trying to accomplish the following:
> > > > > >
> > > > > > file1.xls
> > > > > >
> > > > > > copy worksheet1 from file1.xls
> > > > > >
> > > > > > and then insert into file2.xls without overwriting file1.xls
> > > completely.
> > > > > >
> > > > > > The reason - I have one master xls file with multiple named
> > > worksheets.
> > > > > > Each worksheet relates to another xls file and on a weekly basis
I
> > > want
> > > > > the
> > > > > > master xls file's different worksheets updated so the worksheets
> are
> > > > > > replaced but the main master xls file is not. All I've
> accomplished
> > > so
> > > > > far
> > > > > > is below:
> > > > > >
> > > > > > Public Sub TransferData()
> > > > > >
> > > > > > 'Disable screen updating while the subroutine is run
> > > > > > Application.ScreenUpdating = False
> > > > > >
> > > > > > 'Unprotect all Register worksheet
> > > > > > Worksheets("Register").Select
> > > > > > ActiveSheet.Unprotect
> > > > > >
> > > > > > 'Define Variables
> > > > > > Dim szThisFileName As String
> > > > > > Dim szFileName As String
> > > > > > Dim szWindowName As String
> > > > > > Dim szNotes As String
> > > > > > Dim szPETNumber As String
> > > > > > Dim Response As Integer
> > > > > >
> > > > > > 'Set initial values
> > > > > > szThisFileName = ActiveWorkbook.Name
> > > > > > szWindowName = "Test Risk Transfer.xls"
> > > > > > szFileName = "C:\" & szWindowName
> > > > > > iRow = 1
> > > > > >
> > > > > > 'Check if user wants to continue
> > > > > > If MsgBox("This facility is only for transfering information
> > into
> > > "
> > > > _
> > > > > > + "the BISTD Central Register repository database. " _
> > > > > > + "Are you sure you want to continue?", vbQuestion +
> > vbYesNo)
> > > =
> > > > > vbNo
> > > > > > Then
> > > > > > Exit Sub
> > > > > > End If
> > > > > >
> > > > > > 'Check if there is any data to transfer
> > > > > > Worksheets("Register").Select
> > > > > > If ActiveSheet.Range("C2") = "" Then
> > > > > > MsgBox ("There are no risks in the Register to " _
> > > > > > + "transfer.")
> > > > > > ActiveSheet.Protect
> > > > > > Exit Sub
> > > > > > End If
> > > > > >
> > > > > > 'Create Risk Transfer workbook on C drive
> > > > > > On Error GoTo ir1:
> > > > > > Workbooks.Add
> > > > > > ChDir "C:\"
> > > > > > ActiveWorkbook.SaveAs FileName:=szFileName,
> > FileFormat:=xlNormal,
> > > _
> > > > > > Password:="", WriteResPassword:="",
> > > ReadOnlyRecommended:=False,
> > > > _
> > > > > > CreateBackup:=False
> > > > > > Windows(szWindowName).Activate
> > > > > > Sheets.Add
> > > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > > Windows(szThisFileName).Activate
> > > > > >
> > > > > > 'Add column headings to Stakeholder Transfer workbook
> > > > > > Worksheets("Register").Select
> > > > > > ActiveSheet.Range("C1:V1").Select
> > > > > > Selection.Copy
> > > > > > Windows(szWindowName).Activate
> > > > > > Worksheets("Risk Transfers1").Select
> > > > > > ActiveSheet.Range("B1").Select
> > > > > > ActiveSheet.Paste
> > > > > > ActiveSheet.Range("A1") = "Project_No"
> > > > > > Windows(szThisFileName).Activate
> > > > > >
> > > > > > 'Copy risk data from the Register worksheet and transfer
> > > > > > 'data into temporary workbook in C drive.
> > > > > >
> > > > > > 'Find last record in Register
> > > > > > Call DetermineRange(nor)
> > > > > >
> > > > > > Worksheets("Register").Select
> > > > > > szPETNumber = ActiveSheet.Range("A2")
> > > > > > ActiveSheet.Range("C2:V" & nor).Copy
> > > > > >
> > > > > > 'Truncate Notes and Key Messages fields at 255 characters
> > > > > > 'Worksheets("Transfer Sheet").Select
> > > > > > 'szNotes = Worksheets("Stakeholder " &
> > szStakeholder).Range("C66")
> > > > > > 'szNotes = Left(szNotes, 255)
> > > > > > 'szKeyMessages = Worksheets("Stakeholder " &
> > > > > szStakeholder).Range("C71")
> > > > > > 'szKeyMessages = Left(szKeyMessages, 255)
> > > > > >
> > > > > > 'Paste the copied data into the Risk Transfer workbook
> > > > > > Windows(szWindowName).Activate
> > > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > > ActiveSheet.Range("B2").Select
> > > > > > ActiveSheet.Paste
> > > > > >
> > > > > > 'Write in the Project Number on each row
> > > > > > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> > > > > >
> > > > > > 'Return to the Risk Register
> > > > > > Windows(szThisFileName).Activate
> > > > > > Application.CutCopyMode = False
> > > > > >
> > > > > > 'Save and close risk Transfer workbook
> > > > > > Windows(szWindowName).Activate
> > > > > > ActiveWorkbook.Save
> > > > > > ActiveWindow.Close
> > > > > > Windows(szThisFileName).Activate
> > > > > >
> > > > > >
> > > > > > 'Protect Register worksheet
> > > > > > Worksheets("Register").Select
> > > > > > ActiveSheet.Protect
> > > > > > Worksheets("FrontScreen").Select
> > > > > > Exit Sub
> > > > > >
> > > > > > ir1: Response = MsgBox("You already have a risk Transfer
> workbook
> > "
> > > _
> > > > > > + "in your C Drive. Do you want to " _
> > > > > > + "delete this existing Risk Transfer workbook " _
> > > > > > + "and replace it with a new version?", vbYesNo)
> > > > > > If Response = vbYes Then
> > > > > > MsgBox ("Click the Transfer Data button " _
> > > > > > + "again and when prompted that there is an existing
"
> _
> > > > > > + "risk Transfer file and asking if you " _
> > > > > > + "wish to replace it, click Yes.")
> > > > > > MsgBox ("You will have created a temporary workbook
> > called
> > > > > Book
> > > > > > " _
> > > > > > + "Book*.xls. You will need to delete this when you
> > > finish
> > > > > the
> > > > > > session.")
> > > > > > GoTo ir2:
> > > > > > Else
> > > > > > GoTo ir2:
> > > > > > End If
> > > > > >
> > > > > > ir2: Windows(szThisFileName).Activate
> > > > > > Worksheets("Register").Select
> > > > > > ActiveSheet.Protect
> > > > > > Worksheets("FrontScreen").Select
> > > > > > Exit Sub
> > > > > > End Sub
> > > > > >
> > > > > >
> > > > >
> > > > Sorry for not being clear.....
> > > >
> > > > As above, originally a copy of one sheet from the xls file was
copied
> to
> > a
> > > > newly created xls file.
> > > >
> > > > Instead of that the new xls file will have been already created but
I
> > want
> > > > the vb to copy a defined worksheet across to this this file. There
> will
> > > be
> > > > multiple sheets each of which will be fed by different xls files
> > > >
> > > >
> > >
> > >
> >
> >
>
>

Tom - I've now almost finished a risk and issue register which also maps
risks onto a matrix - would you like a copy for your amusement?

"ohboy!" <[email protected]> wrote in message
news:[email protected]...
> Tom - many thanks that works! Just to verge on being cheeky, how do I get
> the receiving workbook (RegisterCopy) to close after transfer?
>
>
> "Tom Ogilvy" <[email protected]> wrote in message
> news:[email protected]...
> > Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of range
> > Set bk2 = Workbooks("c:\test.xls")
> >
> > if the workbooks are already open, then don't use the path, just use the
> > workbook name. Otherwise you need to open them
> >
> > set Bk1 = Workbooks("Test1.xls")
> >
> > or
> >
> > set Bk1 = Workbooks.Open("C:\Text1.xls")
> >
> > Also, If you want sheet register to replace sheet registercopy, you
would
> > modify the code like this
> >
> > Assumes both workbooks are open and the activeworkbook is the workbook
> > containing the data to be copied (since you activate a sheet named
> > register).
> >
> > Public Sub TransferData()
> >
> > Worksheets("Register").Select
> > ActiveSheet.Unprotect
> > Dim bk1 As Workbook
> > Dim bk2 As Workbook
> > Dim sh1 As Worksheet
> > Dim sh2 As Worksheet
> > Dim idx As Long
> > Set bk1 = ActiveWorkbook
> > Set bk2 = Workbooks("test.xls")
> > Set sh1 = bk1.Worksheets("Register")
> > On Error Resume Next
> > Set sh2 = bk2.Worksheets("RegisterCopy")
> > On Error GoTo 0
> > If Not sh2 Is Nothing Then
> > idx = sh2.Index
> > Application.DisplayAlerts = False
> > sh2.Delete
> > Application.DisplayAlerts = True
> > If idx > 1 Then
> > sh1.Copy after:=bk2.Sheets(idx - 1)
> > Else
> > sh1.Copy before:=bk2.Sheets(2)
> > End If
> > Else
> > sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> > End If
> > Activesheet.Name = "RegisterCopy"
> > End Sub
> >
> > --
> > Regards,
> > Tom Ogilvy
> >
> >
> >
> >
> > --
> > Regards,
> > Tom Ogilvy
> >
> > "ohboy!" <[email protected]> wrote in message
> > news:[email protected]...
> > > Hi Tom,
> > >
> > > Have tried the following but to no avail...
> > >
> > > Public Sub TransferData()
> > >
> > > Worksheets("Register").Select
> > > ActiveSheet.Unprotect
> > > Dim bk1 As Workbook
> > > Dim bk2 As Workbook
> > > Dim sh1 As Worksheet
> > > Dim sh2 As Worksheet
> > > Dim idx As Long
> > > Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of
range
> > > Set bk2 = Workbooks("c:\test.xls")
> > > Set sh1 = bk1.Worksheets("Register")
> > > On Error Resume Next
> > > Set sh2 = bk2.Worksheets("RegisterCopy")
> > > On Error GoTo 0
> > > If Not sh2 Is Nothing Then
> > > idx = sh2.Index
> > > Application.DisplayAlerts = False
> > > sh2.Delete
> > > Application.DisplayAlerts = True
> > > If idx > 1 Then
> > > sh1.Copy after:=bk2.Sheets(idx - 1)
> > > Else
> > > sh1.Copy before:=bk2.Sheets(2)
> > > End If
> > > Else
> > > sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> > > End If
> > > End Sub
> > >
> > > Definately alot simpler than my first approach...
> > >
> > >
> > > "Tom Ogilvy" <[email protected]> wrote in message
> > > news:[email protected]...
> > > > Dim bk1 as Workbook
> > > > Dim bk2 as Workbook
> > > > Dim sh1 as Worksheet
> > > > Dim sh2 as Worksheet
> > > > Dim idx as LOng
> > > > set bk1 = Workbooks("ABC.xls")
> > > > set bk2 = Workbooks("EFG.xls")
> > > > set sh1 = Bk1.Worksheets("Sheet1")
> > > > on Error Resume Next
> > > > set sh2 = bk2.worksheets(sh1.name)
> > > > On Error goto 0
> > > > if not sh2 is nothing then
> > > > idx = sh2.Index
> > > > Application.DisplayAlerts = False
> > > > sh2.delete
> > > > Application.DisplayAlerts = True
> > > > if idx > 1 then
> > > > sh1.copy after:=bk2.sheets(idx-1)
> > > > else
> > > > sh1.copy before:=bk2.Sheets(2)
> > > > end if
> > > > else
> > > > sh1.copy after:=bk2.Worksheets(bk2.Worksheets.count)
> > > > end if
> > > >
> > > > The above will copy Sheet1 from ABC.xls to EFG.xls. If there is a
> > sheet1
> > > in
> > > > EFG.xls, it will replace it. If not, it will add it at the end.
> > > >
> > > > Hopefully you can adapt a similar approach to your code.
> > > >
> > > > --
> > > > Regards,
> > > > Tom Ogilvy
> > > >
> > > >
> > > >
> > > > "ohboy!" <[email protected]> wrote in message
> > > > news:[email protected]...
> > > > >
> > > > > "Tom Ogilvy" <[email protected]> wrote in message
> > > > > news:[email protected]...
> > > > > > What does the below have to do with your question? It appears
to
> be
> > > > > writing
> > > > > > information to a new workbook, not replacing sheets in an
existing
> > > > > workbook.
> > > > > > What actually is your question.
> > > > > >
> > > > > > --
> > > > > > Regards,
> > > > > > Tom Ogilvy
> > > > > >
> > > > > > "ohboy!" <[email protected]> wrote in message
> > > > > > news:[email protected]...
> > > > > > > Good moring all,
> > > > > > >
> > > > > > > I'm trying to accomplish the following:
> > > > > > >
> > > > > > > file1.xls
> > > > > > >
> > > > > > > copy worksheet1 from file1.xls
> > > > > > >
> > > > > > > and then insert into file2.xls without overwriting file1.xls
> > > > completely.
> > > > > > >
> > > > > > > The reason - I have one master xls file with multiple named
> > > > worksheets.
> > > > > > > Each worksheet relates to another xls file and on a weekly
basis
> I
> > > > want
> > > > > > the
> > > > > > > master xls file's different worksheets updated so the
worksheets
> > are
> > > > > > > replaced but the main master xls file is not. All I've
> > accomplished
> > > > so
> > > > > > far
> > > > > > > is below:
> > > > > > >
> > > > > > > Public Sub TransferData()
> > > > > > >
> > > > > > > 'Disable screen updating while the subroutine is run
> > > > > > > Application.ScreenUpdating = False
> > > > > > >
> > > > > > > 'Unprotect all Register worksheet
> > > > > > > Worksheets("Register").Select
> > > > > > > ActiveSheet.Unprotect
> > > > > > >
> > > > > > > 'Define Variables
> > > > > > > Dim szThisFileName As String
> > > > > > > Dim szFileName As String
> > > > > > > Dim szWindowName As String
> > > > > > > Dim szNotes As String
> > > > > > > Dim szPETNumber As String
> > > > > > > Dim Response As Integer
> > > > > > >
> > > > > > > 'Set initial values
> > > > > > > szThisFileName = ActiveWorkbook.Name
> > > > > > > szWindowName = "Test Risk Transfer.xls"
> > > > > > > szFileName = "C:\" & szWindowName
> > > > > > > iRow = 1
> > > > > > >
> > > > > > > 'Check if user wants to continue
> > > > > > > If MsgBox("This facility is only for transfering
information
> > > into
> > > > "
> > > > > _
> > > > > > > + "the BISTD Central Register repository database. "
_
> > > > > > > + "Are you sure you want to continue?", vbQuestion +
> > > vbYesNo)
> > > > =
> > > > > > vbNo
> > > > > > > Then
> > > > > > > Exit Sub
> > > > > > > End If
> > > > > > >
> > > > > > > 'Check if there is any data to transfer
> > > > > > > Worksheets("Register").Select
> > > > > > > If ActiveSheet.Range("C2") = "" Then
> > > > > > > MsgBox ("There are no risks in the Register to " _
> > > > > > > + "transfer.")
> > > > > > > ActiveSheet.Protect
> > > > > > > Exit Sub
> > > > > > > End If
> > > > > > >
> > > > > > > 'Create Risk Transfer workbook on C drive
> > > > > > > On Error GoTo ir1:
> > > > > > > Workbooks.Add
> > > > > > > ChDir "C:\"
> > > > > > > ActiveWorkbook.SaveAs FileName:=szFileName,
> > > FileFormat:=xlNormal,
> > > > _
> > > > > > > Password:="", WriteResPassword:="",
> > > > ReadOnlyRecommended:=False,
> > > > > _
> > > > > > > CreateBackup:=False
> > > > > > > Windows(szWindowName).Activate
> > > > > > > Sheets.Add
> > > > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > > > Windows(szThisFileName).Activate
> > > > > > >
> > > > > > > 'Add column headings to Stakeholder Transfer workbook
> > > > > > > Worksheets("Register").Select
> > > > > > > ActiveSheet.Range("C1:V1").Select
> > > > > > > Selection.Copy
> > > > > > > Windows(szWindowName).Activate
> > > > > > > Worksheets("Risk Transfers1").Select
> > > > > > > ActiveSheet.Range("B1").Select
> > > > > > > ActiveSheet.Paste
> > > > > > > ActiveSheet.Range("A1") = "Project_No"
> > > > > > > Windows(szThisFileName).Activate
> > > > > > >
> > > > > > > 'Copy risk data from the Register worksheet and transfer
> > > > > > > 'data into temporary workbook in C drive.
> > > > > > >
> > > > > > > 'Find last record in Register
> > > > > > > Call DetermineRange(nor)
> > > > > > >
> > > > > > > Worksheets("Register").Select
> > > > > > > szPETNumber = ActiveSheet.Range("A2")
> > > > > > > ActiveSheet.Range("C2:V" & nor).Copy
> > > > > > >
> > > > > > > 'Truncate Notes and Key Messages fields at 255 characters
> > > > > > > 'Worksheets("Transfer Sheet").Select
> > > > > > > 'szNotes = Worksheets("Stakeholder " &
> > > szStakeholder).Range("C66")
> > > > > > > 'szNotes = Left(szNotes, 255)
> > > > > > > 'szKeyMessages = Worksheets("Stakeholder " &
> > > > > > szStakeholder).Range("C71")
> > > > > > > 'szKeyMessages = Left(szKeyMessages, 255)
> > > > > > >
> > > > > > > 'Paste the copied data into the Risk Transfer workbook
> > > > > > > Windows(szWindowName).Activate
> > > > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > > > ActiveSheet.Range("B2").Select
> > > > > > > ActiveSheet.Paste
> > > > > > >
> > > > > > > 'Write in the Project Number on each row
> > > > > > > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> > > > > > >
> > > > > > > 'Return to the Risk Register
> > > > > > > Windows(szThisFileName).Activate
> > > > > > > Application.CutCopyMode = False
> > > > > > >
> > > > > > > 'Save and close risk Transfer workbook
> > > > > > > Windows(szWindowName).Activate
> > > > > > > ActiveWorkbook.Save
> > > > > > > ActiveWindow.Close
> > > > > > > Windows(szThisFileName).Activate
> > > > > > >
> > > > > > >
> > > > > > > 'Protect Register worksheet
> > > > > > > Worksheets("Register").Select
> > > > > > > ActiveSheet.Protect
> > > > > > > Worksheets("FrontScreen").Select
> > > > > > > Exit Sub
> > > > > > >
> > > > > > > ir1: Response = MsgBox("You already have a risk Transfer
> > workbook
> > > "
> > > > _
> > > > > > > + "in your C Drive. Do you want to " _
> > > > > > > + "delete this existing Risk Transfer workbook " _
> > > > > > > + "and replace it with a new version?", vbYesNo)
> > > > > > > If Response = vbYes Then
> > > > > > > MsgBox ("Click the Transfer Data button " _
> > > > > > > + "again and when prompted that there is an
existing
> "
> > _
> > > > > > > + "risk Transfer file and asking if you " _
> > > > > > > + "wish to replace it, click Yes.")
> > > > > > > MsgBox ("You will have created a temporary
workbook
> > > called
> > > > > > Book
> > > > > > > " _
> > > > > > > + "Book*.xls. You will need to delete this when
you
> > > > finish
> > > > > > the
> > > > > > > session.")
> > > > > > > GoTo ir2:
> > > > > > > Else
> > > > > > > GoTo ir2:
> > > > > > > End If
> > > > > > >
> > > > > > > ir2: Windows(szThisFileName).Activate
> > > > > > > Worksheets("Register").Select
> > > > > > > ActiveSheet.Protect
> > > > > > > Worksheets("FrontScreen").Select
> > > > > > > Exit Sub
> > > > > > > End Sub
> > > > > > >
> > > > > > >
> > > > > >
> > > > > Sorry for not being clear.....
> > > > >
> > > > > As above, originally a copy of one sheet from the xls file was
> copied
> > to
> > > a
> > > > > newly created xls file.
> > > > >
> > > > > Instead of that the new xls file will have been already created
but
> I
> > > want
> > > > > the vb to copy a defined worksheet across to this this file.
There
> > will
> > > > be
> > > > > multiple sheets each of which will be fed by different xls files
> > > > >
> > > > >
> > > >
> > > >
> > >
> > >
> >
> >
>
>

bk2.Close SaveChanges:=False (or True)

--
Regards,
Tom Ogilvy


"ohboy!" <[email protected]> wrote in message
news:[email protected]...
> Tom - many thanks that works! Just to verge on being cheeky, how do I get
> the receiving workbook (RegisterCopy) to close after transfer?
>
>
> "Tom Ogilvy" <[email protected]> wrote in message
> news:[email protected]...
> > Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of range
> > Set bk2 = Workbooks("c:\test.xls")
> >
> > if the workbooks are already open, then don't use the path, just use the
> > workbook name. Otherwise you need to open them
> >
> > set Bk1 = Workbooks("Test1.xls")
> >
> > or
> >
> > set Bk1 = Workbooks.Open("C:\Text1.xls")
> >
> > Also, If you want sheet register to replace sheet registercopy, you
would
> > modify the code like this
> >
> > Assumes both workbooks are open and the activeworkbook is the workbook
> > containing the data to be copied (since you activate a sheet named
> > register).
> >
> > Public Sub TransferData()
> >
> > Worksheets("Register").Select
> > ActiveSheet.Unprotect
> > Dim bk1 As Workbook
> > Dim bk2 As Workbook
> > Dim sh1 As Worksheet
> > Dim sh2 As Worksheet
> > Dim idx As Long
> > Set bk1 = ActiveWorkbook
> > Set bk2 = Workbooks("test.xls")
> > Set sh1 = bk1.Worksheets("Register")
> > On Error Resume Next
> > Set sh2 = bk2.Worksheets("RegisterCopy")
> > On Error GoTo 0
> > If Not sh2 Is Nothing Then
> > idx = sh2.Index
> > Application.DisplayAlerts = False
> > sh2.Delete
> > Application.DisplayAlerts = True
> > If idx > 1 Then
> > sh1.Copy after:=bk2.Sheets(idx - 1)
> > Else
> > sh1.Copy before:=bk2.Sheets(2)
> > End If
> > Else
> > sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> > End If
> > Activesheet.Name = "RegisterCopy"
> > End Sub
> >
> > --
> > Regards,
> > Tom Ogilvy
> >
> >
> >
> >
> > --
> > Regards,
> > Tom Ogilvy
> >
> > "ohboy!" <[email protected]> wrote in message
> > news:[email protected]...
> > > Hi Tom,
> > >
> > > Have tried the following but to no avail...
> > >
> > > Public Sub TransferData()
> > >
> > > Worksheets("Register").Select
> > > ActiveSheet.Unprotect
> > > Dim bk1 As Workbook
> > > Dim bk2 As Workbook
> > > Dim sh1 As Worksheet
> > > Dim sh2 As Worksheet
> > > Dim idx As Long
> > > Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of
range
> > > Set bk2 = Workbooks("c:\test.xls")
> > > Set sh1 = bk1.Worksheets("Register")
> > > On Error Resume Next
> > > Set sh2 = bk2.Worksheets("RegisterCopy")
> > > On Error GoTo 0
> > > If Not sh2 Is Nothing Then
> > > idx = sh2.Index
> > > Application.DisplayAlerts = False
> > > sh2.Delete
> > > Application.DisplayAlerts = True
> > > If idx > 1 Then
> > > sh1.Copy after:=bk2.Sheets(idx - 1)
> > > Else
> > > sh1.Copy before:=bk2.Sheets(2)
> > > End If
> > > Else
> > > sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> > > End If
> > > End Sub
> > >
> > > Definately alot simpler than my first approach...
> > >
> > >
> > > "Tom Ogilvy" <[email protected]> wrote in message
> > > news:[email protected]...
> > > > Dim bk1 as Workbook
> > > > Dim bk2 as Workbook
> > > > Dim sh1 as Worksheet
> > > > Dim sh2 as Worksheet
> > > > Dim idx as LOng
> > > > set bk1 = Workbooks("ABC.xls")
> > > > set bk2 = Workbooks("EFG.xls")
> > > > set sh1 = Bk1.Worksheets("Sheet1")
> > > > on Error Resume Next
> > > > set sh2 = bk2.worksheets(sh1.name)
> > > > On Error goto 0
> > > > if not sh2 is nothing then
> > > > idx = sh2.Index
> > > > Application.DisplayAlerts = False
> > > > sh2.delete
> > > > Application.DisplayAlerts = True
> > > > if idx > 1 then
> > > > sh1.copy after:=bk2.sheets(idx-1)
> > > > else
> > > > sh1.copy before:=bk2.Sheets(2)
> > > > end if
> > > > else
> > > > sh1.copy after:=bk2.Worksheets(bk2.Worksheets.count)
> > > > end if
> > > >
> > > > The above will copy Sheet1 from ABC.xls to EFG.xls. If there is a
> > sheet1
> > > in
> > > > EFG.xls, it will replace it. If not, it will add it at the end.
> > > >
> > > > Hopefully you can adapt a similar approach to your code.
> > > >
> > > > --
> > > > Regards,
> > > > Tom Ogilvy
> > > >
> > > >
> > > >
> > > > "ohboy!" <[email protected]> wrote in message
> > > > news:[email protected]...
> > > > >
> > > > > "Tom Ogilvy" <[email protected]> wrote in message
> > > > > news:[email protected]...
> > > > > > What does the below have to do with your question? It appears
to
> be
> > > > > writing
> > > > > > information to a new workbook, not replacing sheets in an
existing
> > > > > workbook.
> > > > > > What actually is your question.
> > > > > >
> > > > > > --
> > > > > > Regards,
> > > > > > Tom Ogilvy
> > > > > >
> > > > > > "ohboy!" <[email protected]> wrote in message
> > > > > > news:[email protected]...
> > > > > > > Good moring all,
> > > > > > >
> > > > > > > I'm trying to accomplish the following:
> > > > > > >
> > > > > > > file1.xls
> > > > > > >
> > > > > > > copy worksheet1 from file1.xls
> > > > > > >
> > > > > > > and then insert into file2.xls without overwriting file1.xls
> > > > completely.
> > > > > > >
> > > > > > > The reason - I have one master xls file with multiple named
> > > > worksheets.
> > > > > > > Each worksheet relates to another xls file and on a weekly
basis
> I
> > > > want
> > > > > > the
> > > > > > > master xls file's different worksheets updated so the
worksheets
> > are
> > > > > > > replaced but the main master xls file is not. All I've
> > accomplished
> > > > so
> > > > > > far
> > > > > > > is below:
> > > > > > >
> > > > > > > Public Sub TransferData()
> > > > > > >
> > > > > > > 'Disable screen updating while the subroutine is run
> > > > > > > Application.ScreenUpdating = False
> > > > > > >
> > > > > > > 'Unprotect all Register worksheet
> > > > > > > Worksheets("Register").Select
> > > > > > > ActiveSheet.Unprotect
> > > > > > >
> > > > > > > 'Define Variables
> > > > > > > Dim szThisFileName As String
> > > > > > > Dim szFileName As String
> > > > > > > Dim szWindowName As String
> > > > > > > Dim szNotes As String
> > > > > > > Dim szPETNumber As String
> > > > > > > Dim Response As Integer
> > > > > > >
> > > > > > > 'Set initial values
> > > > > > > szThisFileName = ActiveWorkbook.Name
> > > > > > > szWindowName = "Test Risk Transfer.xls"
> > > > > > > szFileName = "C:\" & szWindowName
> > > > > > > iRow = 1
> > > > > > >
> > > > > > > 'Check if user wants to continue
> > > > > > > If MsgBox("This facility is only for transfering
information
> > > into
> > > > "
> > > > > _
> > > > > > > + "the BISTD Central Register repository database. "
_
> > > > > > > + "Are you sure you want to continue?", vbQuestion +
> > > vbYesNo)
> > > > =
> > > > > > vbNo
> > > > > > > Then
> > > > > > > Exit Sub
> > > > > > > End If
> > > > > > >
> > > > > > > 'Check if there is any data to transfer
> > > > > > > Worksheets("Register").Select
> > > > > > > If ActiveSheet.Range("C2") = "" Then
> > > > > > > MsgBox ("There are no risks in the Register to " _
> > > > > > > + "transfer.")
> > > > > > > ActiveSheet.Protect
> > > > > > > Exit Sub
> > > > > > > End If
> > > > > > >
> > > > > > > 'Create Risk Transfer workbook on C drive
> > > > > > > On Error GoTo ir1:
> > > > > > > Workbooks.Add
> > > > > > > ChDir "C:\"
> > > > > > > ActiveWorkbook.SaveAs FileName:=szFileName,
> > > FileFormat:=xlNormal,
> > > > _
> > > > > > > Password:="", WriteResPassword:="",
> > > > ReadOnlyRecommended:=False,
> > > > > _
> > > > > > > CreateBackup:=False
> > > > > > > Windows(szWindowName).Activate
> > > > > > > Sheets.Add
> > > > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > > > Windows(szThisFileName).Activate
> > > > > > >
> > > > > > > 'Add column headings to Stakeholder Transfer workbook
> > > > > > > Worksheets("Register").Select
> > > > > > > ActiveSheet.Range("C1:V1").Select
> > > > > > > Selection.Copy
> > > > > > > Windows(szWindowName).Activate
> > > > > > > Worksheets("Risk Transfers1").Select
> > > > > > > ActiveSheet.Range("B1").Select
> > > > > > > ActiveSheet.Paste
> > > > > > > ActiveSheet.Range("A1") = "Project_No"
> > > > > > > Windows(szThisFileName).Activate
> > > > > > >
> > > > > > > 'Copy risk data from the Register worksheet and transfer
> > > > > > > 'data into temporary workbook in C drive.
> > > > > > >
> > > > > > > 'Find last record in Register
> > > > > > > Call DetermineRange(nor)
> > > > > > >
> > > > > > > Worksheets("Register").Select
> > > > > > > szPETNumber = ActiveSheet.Range("A2")
> > > > > > > ActiveSheet.Range("C2:V" & nor).Copy
> > > > > > >
> > > > > > > 'Truncate Notes and Key Messages fields at 255 characters
> > > > > > > 'Worksheets("Transfer Sheet").Select
> > > > > > > 'szNotes = Worksheets("Stakeholder " &
> > > szStakeholder).Range("C66")
> > > > > > > 'szNotes = Left(szNotes, 255)
> > > > > > > 'szKeyMessages = Worksheets("Stakeholder " &
> > > > > > szStakeholder).Range("C71")
> > > > > > > 'szKeyMessages = Left(szKeyMessages, 255)
> > > > > > >
> > > > > > > 'Paste the copied data into the Risk Transfer workbook
> > > > > > > Windows(szWindowName).Activate
> > > > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > > > ActiveSheet.Range("B2").Select
> > > > > > > ActiveSheet.Paste
> > > > > > >
> > > > > > > 'Write in the Project Number on each row
> > > > > > > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> > > > > > >
> > > > > > > 'Return to the Risk Register
> > > > > > > Windows(szThisFileName).Activate
> > > > > > > Application.CutCopyMode = False
> > > > > > >
> > > > > > > 'Save and close risk Transfer workbook
> > > > > > > Windows(szWindowName).Activate
> > > > > > > ActiveWorkbook.Save
> > > > > > > ActiveWindow.Close
> > > > > > > Windows(szThisFileName).Activate
> > > > > > >
> > > > > > >
> > > > > > > 'Protect Register worksheet
> > > > > > > Worksheets("Register").Select
> > > > > > > ActiveSheet.Protect
> > > > > > > Worksheets("FrontScreen").Select
> > > > > > > Exit Sub
> > > > > > >
> > > > > > > ir1: Response = MsgBox("You already have a risk Transfer
> > workbook
> > > "
> > > > _
> > > > > > > + "in your C Drive. Do you want to " _
> > > > > > > + "delete this existing Risk Transfer workbook " _
> > > > > > > + "and replace it with a new version?", vbYesNo)
> > > > > > > If Response = vbYes Then
> > > > > > > MsgBox ("Click the Transfer Data button " _
> > > > > > > + "again and when prompted that there is an
existing
> "
> > _
> > > > > > > + "risk Transfer file and asking if you " _
> > > > > > > + "wish to replace it, click Yes.")
> > > > > > > MsgBox ("You will have created a temporary
workbook
> > > called
> > > > > > Book
> > > > > > > " _
> > > > > > > + "Book*.xls. You will need to delete this when
you
> > > > finish
> > > > > > the
> > > > > > > session.")
> > > > > > > GoTo ir2:
> > > > > > > Else
> > > > > > > GoTo ir2:
> > > > > > > End If
> > > > > > >
> > > > > > > ir2: Windows(szThisFileName).Activate
> > > > > > > Worksheets("Register").Select
> > > > > > > ActiveSheet.Protect
> > > > > > > Worksheets("FrontScreen").Select
> > > > > > > Exit Sub
> > > > > > > End Sub
> > > > > > >
> > > > > > >
> > > > > >
> > > > > Sorry for not being clear.....
> > > > >
> > > > > As above, originally a copy of one sheet from the xls file was
> copied
> > to
> > > a
> > > > > newly created xls file.
> > > > >
> > > > > Instead of that the new xls file will have been already created
but
> I
> > > want
> > > > > the vb to copy a defined worksheet across to this this file.
There
> > will
> > > > be
> > > > > multiple sheets each of which will be fed by different xls files
> > > > >
> > > > >
> > > >
> > > >
> > >
> > >
> >
> >
>
>

If you want to send a copy to [email protected], then sure; I would
appreciate that.

Hopefully from that I will be able to figure out what a risk and issue
register is since it isn't something I am familiar with. I am always eager
to be educated.

I marvel at some of the neat stuff that people do with workbooks -- I have,
on occasion, received some pretty "stunning" workbooks from people asking
for help. It is always interesting for me.

So thank you.

--
Regards,
Tom Ogilvy

"ohboy!" <[email protected]> wrote in message
news:[email protected]...
> Tom - I've now almost finished a risk and issue register which also maps
> risks onto a matrix - would you like a copy for your amusement?
>
> "ohboy!" <[email protected]> wrote in message
> news:[email protected]...
> > Tom - many thanks that works! Just to verge on being cheeky, how do I
get
> > the receiving workbook (RegisterCopy) to close after transfer?
> >
> >
> > "Tom Ogilvy" <[email protected]> wrote in message
> > news:[email protected]...
> > > Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of
range
> > > Set bk2 = Workbooks("c:\test.xls")
> > >
> > > if the workbooks are already open, then don't use the path, just use
the
> > > workbook name. Otherwise you need to open them
> > >
> > > set Bk1 = Workbooks("Test1.xls")
> > >
> > > or
> > >
> > > set Bk1 = Workbooks.Open("C:\Text1.xls")
> > >
> > > Also, If you want sheet register to replace sheet registercopy, you
> would
> > > modify the code like this
> > >
> > > Assumes both workbooks are open and the activeworkbook is the workbook
> > > containing the data to be copied (since you activate a sheet named
> > > register).
> > >
> > > Public Sub TransferData()
> > >
> > > Worksheets("Register").Select
> > > ActiveSheet.Unprotect
> > > Dim bk1 As Workbook
> > > Dim bk2 As Workbook
> > > Dim sh1 As Worksheet
> > > Dim sh2 As Worksheet
> > > Dim idx As Long
> > > Set bk1 = ActiveWorkbook
> > > Set bk2 = Workbooks("test.xls")
> > > Set sh1 = bk1.Worksheets("Register")
> > > On Error Resume Next
> > > Set sh2 = bk2.Worksheets("RegisterCopy")
> > > On Error GoTo 0
> > > If Not sh2 Is Nothing Then
> > > idx = sh2.Index
> > > Application.DisplayAlerts = False
> > > sh2.Delete
> > > Application.DisplayAlerts = True
> > > If idx > 1 Then
> > > sh1.Copy after:=bk2.Sheets(idx - 1)
> > > Else
> > > sh1.Copy before:=bk2.Sheets(2)
> > > End If
> > > Else
> > > sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> > > End If
> > > Activesheet.Name = "RegisterCopy"
> > > End Sub
> > >
> > > --
> > > Regards,
> > > Tom Ogilvy
> > >
> > >
> > >
> > >
> > > --
> > > Regards,
> > > Tom Ogilvy
> > >
> > > "ohboy!" <[email protected]> wrote in message
> > > news:[email protected]...
> > > > Hi Tom,
> > > >
> > > > Have tried the following but to no avail...
> > > >
> > > > Public Sub TransferData()
> > > >
> > > > Worksheets("Register").Select
> > > > ActiveSheet.Unprotect
> > > > Dim bk1 As Workbook
> > > > Dim bk2 As Workbook
> > > > Dim sh1 As Worksheet
> > > > Dim sh2 As Worksheet
> > > > Dim idx As Long
> > > > Set bk1 = Workbooks("c:\test1.xls") <Stops here - error9 out of
> range
> > > > Set bk2 = Workbooks("c:\test.xls")
> > > > Set sh1 = bk1.Worksheets("Register")
> > > > On Error Resume Next
> > > > Set sh2 = bk2.Worksheets("RegisterCopy")
> > > > On Error GoTo 0
> > > > If Not sh2 Is Nothing Then
> > > > idx = sh2.Index
> > > > Application.DisplayAlerts = False
> > > > sh2.Delete
> > > > Application.DisplayAlerts = True
> > > > If idx > 1 Then
> > > > sh1.Copy after:=bk2.Sheets(idx - 1)
> > > > Else
> > > > sh1.Copy before:=bk2.Sheets(2)
> > > > End If
> > > > Else
> > > > sh1.Copy after:=bk2.Worksheets(bk2.Worksheets.Count)
> > > > End If
> > > > End Sub
> > > >
> > > > Definately alot simpler than my first approach...
> > > >
> > > >
> > > > "Tom Ogilvy" <[email protected]> wrote in message
> > > > news:[email protected]...
> > > > > Dim bk1 as Workbook
> > > > > Dim bk2 as Workbook
> > > > > Dim sh1 as Worksheet
> > > > > Dim sh2 as Worksheet
> > > > > Dim idx as LOng
> > > > > set bk1 = Workbooks("ABC.xls")
> > > > > set bk2 = Workbooks("EFG.xls")
> > > > > set sh1 = Bk1.Worksheets("Sheet1")
> > > > > on Error Resume Next
> > > > > set sh2 = bk2.worksheets(sh1.name)
> > > > > On Error goto 0
> > > > > if not sh2 is nothing then
> > > > > idx = sh2.Index
> > > > > Application.DisplayAlerts = False
> > > > > sh2.delete
> > > > > Application.DisplayAlerts = True
> > > > > if idx > 1 then
> > > > > sh1.copy after:=bk2.sheets(idx-1)
> > > > > else
> > > > > sh1.copy before:=bk2.Sheets(2)
> > > > > end if
> > > > > else
> > > > > sh1.copy after:=bk2.Worksheets(bk2.Worksheets.count)
> > > > > end if
> > > > >
> > > > > The above will copy Sheet1 from ABC.xls to EFG.xls. If there is a
> > > sheet1
> > > > in
> > > > > EFG.xls, it will replace it. If not, it will add it at the end.
> > > > >
> > > > > Hopefully you can adapt a similar approach to your code.
> > > > >
> > > > > --
> > > > > Regards,
> > > > > Tom Ogilvy
> > > > >
> > > > >
> > > > >
> > > > > "ohboy!" <[email protected]> wrote in message
> > > > > news:[email protected]...
> > > > > >
> > > > > > "Tom Ogilvy" <[email protected]> wrote in message
> > > > > > news:[email protected]...
> > > > > > > What does the below have to do with your question? It appears
> to
> > be
> > > > > > writing
> > > > > > > information to a new workbook, not replacing sheets in an
> existing
> > > > > > workbook.
> > > > > > > What actually is your question.
> > > > > > >
> > > > > > > --
> > > > > > > Regards,
> > > > > > > Tom Ogilvy
> > > > > > >
> > > > > > > "ohboy!" <[email protected]> wrote in message
> > > > > > > news:[email protected]...
> > > > > > > > Good moring all,
> > > > > > > >
> > > > > > > > I'm trying to accomplish the following:
> > > > > > > >
> > > > > > > > file1.xls
> > > > > > > >
> > > > > > > > copy worksheet1 from file1.xls
> > > > > > > >
> > > > > > > > and then insert into file2.xls without overwriting file1.xls
> > > > > completely.
> > > > > > > >
> > > > > > > > The reason - I have one master xls file with multiple named
> > > > > worksheets.
> > > > > > > > Each worksheet relates to another xls file and on a weekly
> basis
> > I
> > > > > want
> > > > > > > the
> > > > > > > > master xls file's different worksheets updated so the
> worksheets
> > > are
> > > > > > > > replaced but the main master xls file is not. All I've
> > > accomplished
> > > > > so
> > > > > > > far
> > > > > > > > is below:
> > > > > > > >
> > > > > > > > Public Sub TransferData()
> > > > > > > >
> > > > > > > > 'Disable screen updating while the subroutine is run
> > > > > > > > Application.ScreenUpdating = False
> > > > > > > >
> > > > > > > > 'Unprotect all Register worksheet
> > > > > > > > Worksheets("Register").Select
> > > > > > > > ActiveSheet.Unprotect
> > > > > > > >
> > > > > > > > 'Define Variables
> > > > > > > > Dim szThisFileName As String
> > > > > > > > Dim szFileName As String
> > > > > > > > Dim szWindowName As String
> > > > > > > > Dim szNotes As String
> > > > > > > > Dim szPETNumber As String
> > > > > > > > Dim Response As Integer
> > > > > > > >
> > > > > > > > 'Set initial values
> > > > > > > > szThisFileName = ActiveWorkbook.Name
> > > > > > > > szWindowName = "Test Risk Transfer.xls"
> > > > > > > > szFileName = "C:\" & szWindowName
> > > > > > > > iRow = 1
> > > > > > > >
> > > > > > > > 'Check if user wants to continue
> > > > > > > > If MsgBox("This facility is only for transfering
> information
> > > > into
> > > > > "
> > > > > > _
> > > > > > > > + "the BISTD Central Register repository database.
"
> _
> > > > > > > > + "Are you sure you want to continue?", vbQuestion +
> > > > vbYesNo)
> > > > > =
> > > > > > > vbNo
> > > > > > > > Then
> > > > > > > > Exit Sub
> > > > > > > > End If
> > > > > > > >
> > > > > > > > 'Check if there is any data to transfer
> > > > > > > > Worksheets("Register").Select
> > > > > > > > If ActiveSheet.Range("C2") = "" Then
> > > > > > > > MsgBox ("There are no risks in the Register to " _
> > > > > > > > + "transfer.")
> > > > > > > > ActiveSheet.Protect
> > > > > > > > Exit Sub
> > > > > > > > End If
> > > > > > > >
> > > > > > > > 'Create Risk Transfer workbook on C drive
> > > > > > > > On Error GoTo ir1:
> > > > > > > > Workbooks.Add
> > > > > > > > ChDir "C:\"
> > > > > > > > ActiveWorkbook.SaveAs FileName:=szFileName,
> > > > FileFormat:=xlNormal,
> > > > > _
> > > > > > > > Password:="", WriteResPassword:="",
> > > > > ReadOnlyRecommended:=False,
> > > > > > _
> > > > > > > > CreateBackup:=False
> > > > > > > > Windows(szWindowName).Activate
> > > > > > > > Sheets.Add
> > > > > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > > > > Windows(szThisFileName).Activate
> > > > > > > >
> > > > > > > > 'Add column headings to Stakeholder Transfer workbook
> > > > > > > > Worksheets("Register").Select
> > > > > > > > ActiveSheet.Range("C1:V1").Select
> > > > > > > > Selection.Copy
> > > > > > > > Windows(szWindowName).Activate
> > > > > > > > Worksheets("Risk Transfers1").Select
> > > > > > > > ActiveSheet.Range("B1").Select
> > > > > > > > ActiveSheet.Paste
> > > > > > > > ActiveSheet.Range("A1") = "Project_No"
> > > > > > > > Windows(szThisFileName).Activate
> > > > > > > >
> > > > > > > > 'Copy risk data from the Register worksheet and transfer
> > > > > > > > 'data into temporary workbook in C drive.
> > > > > > > >
> > > > > > > > 'Find last record in Register
> > > > > > > > Call DetermineRange(nor)
> > > > > > > >
> > > > > > > > Worksheets("Register").Select
> > > > > > > > szPETNumber = ActiveSheet.Range("A2")
> > > > > > > > ActiveSheet.Range("C2:V" & nor).Copy
> > > > > > > >
> > > > > > > > 'Truncate Notes and Key Messages fields at 255 characters
> > > > > > > > 'Worksheets("Transfer Sheet").Select
> > > > > > > > 'szNotes = Worksheets("Stakeholder " &
> > > > szStakeholder).Range("C66")
> > > > > > > > 'szNotes = Left(szNotes, 255)
> > > > > > > > 'szKeyMessages = Worksheets("Stakeholder " &
> > > > > > > szStakeholder).Range("C71")
> > > > > > > > 'szKeyMessages = Left(szKeyMessages, 255)
> > > > > > > >
> > > > > > > > 'Paste the copied data into the Risk Transfer workbook
> > > > > > > > Windows(szWindowName).Activate
> > > > > > > > ActiveSheet.Name = "Risk Transfers1"
> > > > > > > > ActiveSheet.Range("B2").Select
> > > > > > > > ActiveSheet.Paste
> > > > > > > >
> > > > > > > > 'Write in the Project Number on each row
> > > > > > > > ActiveSheet.Range("A2:A" & nor) = szPETNumber
> > > > > > > >
> > > > > > > > 'Return to the Risk Register
> > > > > > > > Windows(szThisFileName).Activate
> > > > > > > > Application.CutCopyMode = False
> > > > > > > >
> > > > > > > > 'Save and close risk Transfer workbook
> > > > > > > > Windows(szWindowName).Activate
> > > > > > > > ActiveWorkbook.Save
> > > > > > > > ActiveWindow.Close
> > > > > > > > Windows(szThisFileName).Activate
> > > > > > > >
> > > > > > > >
> > > > > > > > 'Protect Register worksheet
> > > > > > > > Worksheets("Register").Select
> > > > > > > > ActiveSheet.Protect
> > > > > > > > Worksheets("FrontScreen").Select
> > > > > > > > Exit Sub
> > > > > > > >
> > > > > > > > ir1: Response = MsgBox("You already have a risk Transfer
> > > workbook
> > > > "
> > > > > _
> > > > > > > > + "in your C Drive. Do you want to " _
> > > > > > > > + "delete this existing Risk Transfer workbook " _
> > > > > > > > + "and replace it with a new version?", vbYesNo)
> > > > > > > > If Response = vbYes Then
> > > > > > > > MsgBox ("Click the Transfer Data button " _
> > > > > > > > + "again and when prompted that there is an
> existing
> > "
> > > _
> > > > > > > > + "risk Transfer file and asking if you " _
> > > > > > > > + "wish to replace it, click Yes.")
> > > > > > > > MsgBox ("You will have created a temporary
> workbook
> > > > called
> > > > > > > Book
> > > > > > > > " _
> > > > > > > > + "Book*.xls. You will need to delete this when
> you
> > > > > finish
> > > > > > > the
> > > > > > > > session.")
> > > > > > > > GoTo ir2:
> > > > > > > > Else
> > > > > > > > GoTo ir2:
> > > > > > > > End If
> > > > > > > >
> > > > > > > > ir2: Windows(szThisFileName).Activate
> > > > > > > > Worksheets("Register").Select
> > > > > > > > ActiveSheet.Protect
> > > > > > > > Worksheets("FrontScreen").Select
> > > > > > > > Exit Sub
> > > > > > > > End Sub
> > > > > > > >
> > > > > > > >
> > > > > > >
> > > > > > Sorry for not being clear.....
> > > > > >
> > > > > > As above, originally a copy of one sheet from the xls file was
> > copied
> > > to
> > > > a
> > > > > > newly created xls file.
> > > > > >
> > > > > > Instead of that the new xls file will have been already created
> but
> > I
> > > > want
> > > > > > the vb to copy a defined worksheet across to this this file.
> There
> > > will
> > > > > be
> > > > > > multiple sheets each of which will be fed by different xls files
> > > > > >
> > > > > >
> > > > >
> > > > >
> > > >
> > > >
> > >
> > >
> >
> >
>
>