|
|
|
|
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!" wrote in message
...
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" wrote in message
...
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 befo=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!" wrote in message
...
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 befo=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" wrote in message
...
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 befo=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!" wrote in message
...
"Tom Ogilvy" wrote in message
...
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!" wrote in message
...
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
|