Home |
Search |
Today's Posts |
#1
|
|||
|
|||
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 |
#2
|
|||
|
|||
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 |
#3
|
|||
|
|||
"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 |
#4
|
|||
|
|||
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 |
#5
|
|||
|
|||
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" 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 |
#6
|
|||
|
|||
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 |
#7
|
|||
|
|||
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 |
#8
|
|||
|
|||
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 |
#9
|
|||
|
|||
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 |
#10
|
|||
|
|||
bk2.Close SaveChanges:=False (or True)
-- Regards, Tom Ogilvy "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 |
#11
|
|||
|
|||
|
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Problem Editing Macro in Shared Excel File | Excel Discussion (Misc queries) | |||
opening file problem please help | Excel Discussion (Misc queries) | |||
Problem with xlusrgal.xls file | Charts and Charting in Excel | |||
File is locked for Editing by user problem | Excel Discussion (Misc queries) | |||
import problem on huge xls file | Excel Worksheet Functions |