Last month, Peter T posted the macro below.

The intention of this macro:
To copy the contents (including formatting) of each worksheet in a
workbook, to another workbook, and to carry out this copy in such a way
that file corruption is not transferred along with the copy.

The macro works, but there are two glitches that I'm sure would be easy
to fix by someone who knew were doing! :)

1. In the original workbook, there are formulas which refer to cells in
other sheets. After the copy, these formulae refer back to the original
workbook; they aren't local to the new workbook.

2. Page Setup information isn't transferred (several of my worksheets,
but not all, have different Page Sizes, Orientations, and Scales. There
are no headers and footers.

Thanks in advance!

Darren
Peter T's Macro:

Sub WorkBookCopy()
Dim i As Long
Dim ws As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Dim nm As Name
Dim nmNew
Dim wsNew As Worksheet

Application.Calculation = xlCalculationManual
Set wbOrig = ThisWorkbook
Application.SheetsInNewWorkbook = 1
Set wbNew = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each ws In wbOrig.Worksheets
i = i + 1
If i = 1 Then
wbNew.Worksheets(1).Name = ws.Name
Else
wbNew.Worksheets.Add(after:=wbNew.Worksheets(i - 1)).Name =
ws.Name
End If
Next

With wbNew.Names
' if not 100% sure the nm.RefersTo string is less than 255
' don't use this (could be a lot more work involved)
For Each nm In wbOrig.Names
.Add nm.Name, nm.RefersTo
Next
End With

Application.DisplayAlerts = False
i = 0
With wbNew
For Each ws In wbOrig.Worksheets
i = i + 1
ws.Cells.Copy .Worksheets(i).Cells
Next
End With

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Darren

Hi Darren,

The macro works, but there are two glitches

surely not !

OK, there could be loads of things that don't copy over, as I mentioned in
the original thread:

"I should emphasize the macro was quickly put together,
lightly tested and as I said "for ideas". So you will certainly need to
check the integrity of the new workbook"

Re 1. When done you could try manually Edit replace links or try
'wbNew.ChangeLink' as in the revised macro below.

Re 2. Actual print areas should copy over with the hidden names
"Print_Area". PageSetUp requires more work, how much will depend on your
needs.

For others looking the original purpose of this macro was to rebuild what
appeared to be a heavily corrupted workbook of the OP. Therefore
wb.SaveCopyAs would merely duplicate the corruption, potentially so might
copying over sheets. The macro is still far from complete, it's a one off
type of thing so add whatever is missing for individual workbooks, eg Chart
sheets.

Sub WorkBookCopy()
Dim i As Long
Dim ws As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Dim nm As Name
Dim nmNew
Dim wsNew As Worksheet
Dim psOrig As PageSetup
Dim psNew As PageSetup

Application.Calculation = xlCalculationManual
Set wbOrig = ThisWorkbook
Application.SheetsInNewWorkbook = 1
Set wbNew = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each ws In wbOrig.Worksheets
i = i + 1
If i = 1 Then
Set wsNew = wbNew.Worksheets(1)
Else
Set wsNew = wbNew.Worksheets.Add(after:=wbNew.Worksheets(i - 1))
End If
wsNew.Name = ws.Name
Set psOrig = ws.PageSetup
Set psNew = wsNew.PageSetup

With psOrig
psNew.CenterFooter = .CenterFooter
psNew.CenterHeader = .CenterHeader
psNew.PrintHeadings = .PrintHeadings
' and any others, manually type "psNew."
' and after the dot look at the intellisense
End With
Next

With wbNew.Names
' if not 100% sure the nm.RefersTo string is less than 255
' don't use this (could be a lot more work involved)
For Each nm In wbOrig.Names
.Add nm.Name, nm.RefersTo
Next
End With

Application.DisplayAlerts = False
i = 0
With wbNew
For Each ws In wbOrig.Worksheets
i = i + 1
ws.Cells.Copy .Worksheets(i).Cells
Next
End With

wbNew.ChangeLink Name:=wbOrig.Name, NewName:= _
wbNew.Name, Type:=xlExcelLinks

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Regards,
Peter T



"Darren Hill" wrote in message
...
Last month, Peter T posted the macro below.

The intention of this macro:
To copy the contents (including formatting) of each worksheet in a
workbook, to another workbook, and to carry out this copy in such a way
that file corruption is not transferred along with the copy.

The macro works, but there are two glitches that I'm sure would be easy
to fix by someone who knew were doing! :)

1. In the original workbook, there are formulas which refer to cells in
other sheets. After the copy, these formulae refer back to the original
workbook; they aren't local to the new workbook.

2. Page Setup information isn't transferred (several of my worksheets,
but not all, have different Page Sizes, Orientations, and Scales. There
are no headers and footers.

Thanks in advance!

Darren
Peter T's Macro:

Sub WorkBookCopy()
Dim i As Long
Dim ws As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Dim nm As Name
Dim nmNew
Dim wsNew As Worksheet

Application.Calculation = xlCalculationManual
Set wbOrig = ThisWorkbook
Application.SheetsInNewWorkbook = 1
Set wbNew = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each ws In wbOrig.Worksheets
i = i + 1
If i = 1 Then
wbNew.Worksheets(1).Name = ws.Name
Else
wbNew.Worksheets.Add(after:=wbNew.Worksheets(i - 1)).Name =
ws.Name
End If
Next

With wbNew.Names
' if not 100% sure the nm.RefersTo string is less than 255
' don't use this (could be a lot more work involved)
For Each nm In wbOrig.Names
.Add nm.Name, nm.RefersTo
Next
End With

Application.DisplayAlerts = False
i = 0
With wbNew
For Each ws In wbOrig.Worksheets
i = i + 1
ws.Cells.Copy .Worksheets(i).Cells
Next
End With

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Darren

Fantastic, Peter!
I've figured out the pagesetup settings I need and it all works. Yay!
Thanks again.

While you're on a roll :) I have one more question/request:

I've added some pseduo-code below to handle some shapes I have on the
sheets, but I'm not sure how to do a test "Does this shape exist". Can
you look it over and correct my code?
Just so you know: I have two Pictures (Shapes) in the workbook, called
"logo1" and "logo2". There are found in several places and aren#t always
the same size. Your Copy macro does copy them over, but their sizes
change dramatically. The code below is supposed to te4st if the pictures
exist in the current worksheet, and correct their sizes if so.

I was thinking of adding a structure like the following in side the
"For Each ws In wbOrig.Worksheets"
loop

'Here's the new stuff
' I'd move the Dims to the top - just here so you can see them.
Dim shLogo1 as shapes, shLogo2 as Shapes
' not sure how to do this next test:
If ws.shapes("logo1").exists then
' once that test works, will the following work okay?
set shlogo1 = wsnew.shapes("logo1")
with shlogo1
.left = ws.shapes("logo1").left
.top = ws.shapes("logo1").top
.width = ws.shapes("logo1").width
.height = ws.shapes("logo1").height
end with
end if
' then repeat for "logo2"
Next


Have I thanked you enough yet? I don't think so: Thanks!

Darren


Peter T wrote:
Hi Darren,

The macro works, but there are two glitches

surely not !

OK, there could be loads of things that don't copy over, as I mentioned in
the original thread:

"I should emphasize the macro was quickly put together,
lightly tested and as I said "for ideas". So you will certainly need to
check the integrity of the new workbook"

Re 1. When done you could try manually Edit replace links or try
'wbNew.ChangeLink' as in the revised macro below.

Re 2. Actual print areas should copy over with the hidden names
"Print_Area". PageSetUp requires more work, how much will depend on your
needs.

For others looking the original purpose of this macro was to rebuild what
appeared to be a heavily corrupted workbook of the OP. Therefore
wb.SaveCopyAs would merely duplicate the corruption, potentially so might
copying over sheets. The macro is still far from complete, it's a one off
type of thing so add whatever is missing for individual workbooks, eg Chart
sheets.

Sub WorkBookCopy()
Dim i As Long
Dim ws As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Dim nm As Name
Dim nmNew
Dim wsNew As Worksheet
Dim psOrig As PageSetup
Dim psNew As PageSetup

Application.Calculation = xlCalculationManual
Set wbOrig = ThisWorkbook
Application.SheetsInNewWorkbook = 1
Set wbNew = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each ws In wbOrig.Worksheets
i = i + 1
If i = 1 Then
Set wsNew = wbNew.Worksheets(1)
Else
Set wsNew = wbNew.Worksheets.Add(after:=wbNew.Worksheets(i - 1))
End If
wsNew.Name = ws.Name
Set psOrig = ws.PageSetup
Set psNew = wsNew.PageSetup

With psOrig
psNew.CenterFooter = .CenterFooter
psNew.CenterHeader = .CenterHeader
psNew.PrintHeadings = .PrintHeadings
' and any others, manually type "psNew."
' and after the dot look at the intellisense
End With
Next

With wbNew.Names
' if not 100% sure the nm.RefersTo string is less than 255
' don't use this (could be a lot more work involved)
For Each nm In wbOrig.Names
.Add nm.Name, nm.RefersTo
Next
End With

Application.DisplayAlerts = False
i = 0
With wbNew
For Each ws In wbOrig.Worksheets
i = i + 1
ws.Cells.Copy .Worksheets(i).Cells
Next
End With

wbNew.ChangeLink Name:=wbOrig.Name, NewName:= _
wbNew.Name, Type:=xlExcelLinks

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Regards,
Peter T

Something new has come up, Peter.

When running the macro today I get a few error messages AFTER saving the
new file and as I'm closing the original.
The first error is "The picture is too large and will be truncated."

When I click OK, I get the same message again.

When I click OK, I get "Excel cannot complete this task with available
resources. Choose less data or close other applications."

Despite these errors, the macro does complete properly. So I'm not too
concerned (a quick reboot and all should be well) - but do you know what
might be causing them?

Further information:
The error messages didn't happen yesterday, and the workbook I'm
applying the macro to hasn't changed.

I haven't put any shape modifying code in yet, so it's nothing to do
with that.


Thanks,
Darren

Hi again,

Firstly, on reflection it might be better to add a separate loop
(worksheets) at the end (after copying over the data) to do the PageSetUp
stuff. Might be false economy to do it in the first loop.

I haven't pasted your code into the VBE so comments merely after a 'glance'
of your pseudo code

change
Dim shLogo1 as shapes, shLogo2 as Shapes
to
Dim shLogo1 as shape, shLogo2 as Shape

try this

On error resume next
set shLogo1 = nothing
set shLogo1 = wsOrig.shapes("logo1")
on error goto 0
if not shLogo1 is nothing then
with shlogo1
' just as you show below though I image not necessary to change .left & .top


Another way, air-code

Dim picOrig as Picture, picNew as Picture
for each picOrig in wsOrig.Pictures
with picOrig
set picNew = wsNew.Pictures(.Name)
picNew.Width = .width
picnew.height = .height
end with
next

Regards,
Peter T

"Darren Hill" wrote in message
...
Fantastic, Peter!
I've figured out the pagesetup settings I need and it all works. Yay!
Thanks again.

While you're on a roll :) I have one more question/request:

I've added some pseduo-code below to handle some shapes I have on the
sheets, but I'm not sure how to do a test "Does this shape exist". Can
you look it over and correct my code?
Just so you know: I have two Pictures (Shapes) in the workbook, called
"logo1" and "logo2". There are found in several places and aren#t always
the same size. Your Copy macro does copy them over, but their sizes
change dramatically. The code below is supposed to te4st if the pictures
exist in the current worksheet, and correct their sizes if so.

I was thinking of adding a structure like the following in side the
"For Each ws In wbOrig.Worksheets"
loop

'Here's the new stuff
' I'd move the Dims to the top - just here so you can see them.
Dim shLogo1 as shapes, shLogo2 as Shapes
' not sure how to do this next test:
If ws.shapes("logo1").exists then
' once that test works, will the following work okay?
set shlogo1 = wsnew.shapes("logo1")
with shlogo1
.left = ws.shapes("logo1").left
.top = ws.shapes("logo1").top
.width = ws.shapes("logo1").width
.height = ws.shapes("logo1").height
end with
end if
' then repeat for "logo2"
Next


Have I thanked you enough yet? I don't think so: Thanks!

Darren


Peter T wrote:
Hi Darren,

The macro works, but there are two glitches

surely not !

OK, there could be loads of things that don't copy over, as I mentioned
in
the original thread:

"I should emphasize the macro was quickly put together,
lightly tested and as I said "for ideas". So you will certainly need to
check the integrity of the new workbook"

Re 1. When done you could try manually Edit replace links or try
'wbNew.ChangeLink' as in the revised macro below.

Re 2. Actual print areas should copy over with the hidden names
"Print_Area". PageSetUp requires more work, how much will depend on your
needs.

For others looking the original purpose of this macro was to rebuild
what
appeared to be a heavily corrupted workbook of the OP. Therefore
wb.SaveCopyAs would merely duplicate the corruption, potentially so
might
copying over sheets. The macro is still far from complete, it's a one
off
type of thing so add whatever is missing for individual workbooks, eg
Chart
sheets.

Sub WorkBookCopy()
Dim i As Long
Dim ws As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Dim nm As Name
Dim nmNew
Dim wsNew As Worksheet
Dim psOrig As PageSetup
Dim psNew As PageSetup

Application.Calculation = xlCalculationManual
Set wbOrig = ThisWorkbook
Application.SheetsInNewWorkbook = 1
Set wbNew = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each ws In wbOrig.Worksheets
i = i + 1
If i = 1 Then
Set wsNew = wbNew.Worksheets(1)
Else
Set wsNew = wbNew.Worksheets.Add(after:=wbNew.Worksheets(i -
1))
End If
wsNew.Name = ws.Name
Set psOrig = ws.PageSetup
Set psNew = wsNew.PageSetup

With psOrig
psNew.CenterFooter = .CenterFooter
psNew.CenterHeader = .CenterHeader
psNew.PrintHeadings = .PrintHeadings
' and any others, manually type "psNew."
' and after the dot look at the intellisense
End With
Next

With wbNew.Names
' if not 100% sure the nm.RefersTo string is less than 255
' don't use this (could be a lot more work involved)
For Each nm In wbOrig.Names
.Add nm.Name, nm.RefersTo
Next
End With

Application.DisplayAlerts = False
i = 0
With wbNew
For Each ws In wbOrig.Worksheets
i = i + 1
ws.Cells.Copy .Worksheets(i).Cells
Next
End With

wbNew.ChangeLink Name:=wbOrig.Name, NewName:= _
wbNew.Name, Type:=xlExcelLinks

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Regards,
Peter T

Hi, Peter.

I'm having a problem with the picture code.
After the cells copy loop I added this, and it doesn't appear to do
anything (no error messages either):

i = 0
For Each ws In wbOrig.Worksheets
i = i + 1
Set wsNew = wbNew.Worksheets(i)
' I also tried
'Set wsNew = wbNew.Worksheets(ws.name)
On Error Resume Next
Set shLogo = Nothing
Set shLogo = ws.Shapes("logo1")
On Error GoTo 0
If Not shLogo Is Nothing Then
With wsNew.Shapes("logo1")
.Width = shLogo.Width
.Height = shLogo.Height
End With
End If

On Error Resume Next
Set shLogo = Nothing
Set shLogo = ws.Shapes("logo1")
On Error GoTo 0
If Not shLogo Is Nothing Then
With wsNew.Shapes("logo1")
.Width = shLogo.Width
.Height = shLogo.Height
End With
End If
Next

I then tried the other code, in the same for next loop as above:

For Each ws In wbOrig.Worksheets
Set wsNew = wbNew.Worksheets(ws.name)

For Each picOrig In ws.Pictures
With picOrig
Set picNew = wsNew.Pictures(.Name)
picNew.Width = .Width
picNew.Height = .Height
End With
Next
Next
This also appears to do nothing. Is there something wrong with my for
each loop?
I like this code better than the first, but I'd like it even better if I
could make it work :)

Darren

Peter T wrote:
Hi again,

Firstly, on reflection it might be better to add a separate loop
(worksheets) at the end (after copying over the data) to do the PageSetUp
stuff. Might be false economy to do it in the first loop.

I haven't pasted your code into the VBE so comments merely after a 'glance'
of your pseudo code

change
Dim shLogo1 as shapes, shLogo2 as Shapes
to
Dim shLogo1 as shape, shLogo2 as Shape

try this

On error resume next
set shLogo1 = nothing
set shLogo1 = wsOrig.shapes("logo1")
on error goto 0
if not shLogo1 is nothing then
with shlogo1
' just as you show below though I image not necessary to change .left & .top


Another way, air-code

Dim picOrig as Picture, picNew as Picture
for each picOrig in wsOrig.Pictures
with picOrig
set picNew = wsNew.Pictures(.Name)
picNew.Width = .width
picnew.height = .height
end with
next

Regards,
Peter T

"Darren Hill" wrote in message
...
Fantastic, Peter!
I've figured out the pagesetup settings I need and it all works. Yay!
Thanks again.

While you're on a roll :) I have one more question/request:

I've added some pseduo-code below to handle some shapes I have on the
sheets, but I'm not sure how to do a test "Does this shape exist". Can
you look it over and correct my code?
Just so you know: I have two Pictures (Shapes) in the workbook, called
"logo1" and "logo2". There are found in several places and aren#t always
the same size. Your Copy macro does copy them over, but their sizes
change dramatically. The code below is supposed to te4st if the pictures
exist in the current worksheet, and correct their sizes if so.

I was thinking of adding a structure like the following in side the
"For Each ws In wbOrig.Worksheets"
loop

'Here's the new stuff
' I'd move the Dims to the top - just here so you can see them.
Dim shLogo1 as shapes, shLogo2 as Shapes
' not sure how to do this next test:
If ws.shapes("logo1").exists then
' once that test works, will the following work okay?
set shlogo1 = wsnew.shapes("logo1")
with shlogo1
.left = ws.shapes("logo1").left
.top = ws.shapes("logo1").top
.width = ws.shapes("logo1").width
.height = ws.shapes("logo1").height
end with
end if
' then repeat for "logo2"
Next


Have I thanked you enough yet? I don't think so: Thanks!

Darren


Peter T wrote:
Hi Darren,

The macro works, but there are two glitches
surely not !

OK, there could be loads of things that don't copy over, as I mentioned
in
the original thread:

"I should emphasize the macro was quickly put together,
lightly tested and as I said "for ideas". So you will certainly need to
check the integrity of the new workbook"

Re 1. When done you could try manually Edit replace links or try
'wbNew.ChangeLink' as in the revised macro below.

Re 2. Actual print areas should copy over with the hidden names
"Print_Area". PageSetUp requires more work, how much will depend on your
needs.

For others looking the original purpose of this macro was to rebuild
what
appeared to be a heavily corrupted workbook of the OP. Therefore
wb.SaveCopyAs would merely duplicate the corruption, potentially so
might
copying over sheets. The macro is still far from complete, it's a one
off
type of thing so add whatever is missing for individual workbooks, eg
Chart
sheets.

Sub WorkBookCopy()
Dim i As Long
Dim ws As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Dim nm As Name
Dim nmNew
Dim wsNew As Worksheet
Dim psOrig As PageSetup
Dim psNew As PageSetup

Application.Calculation = xlCalculationManual
Set wbOrig = ThisWorkbook
Application.SheetsInNewWorkbook = 1
Set wbNew = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each ws In wbOrig.Worksheets
i = i + 1
If i = 1 Then
Set wsNew = wbNew.Worksheets(1)
Else
Set wsNew = wbNew.Worksheets.Add(after:=wbNew.Worksheets(i -
1))
End If
wsNew.Name = ws.Name
Set psOrig = ws.PageSetup
Set psNew = wsNew.PageSetup

With psOrig
psNew.CenterFooter = .CenterFooter
psNew.CenterHeader = .CenterHeader
psNew.PrintHeadings = .PrintHeadings
' and any others, manually type "psNew."
' and after the dot look at the intellisense
End With
Next

With wbNew.Names
' if not 100% sure the nm.RefersTo string is less than 255
' don't use this (could be a lot more work involved)
For Each nm In wbOrig.Names
.Add nm.Name, nm.RefersTo
Next
End With

Application.DisplayAlerts = False
i = 0
With wbNew
For Each ws In wbOrig.Worksheets
i = i + 1
ws.Cells.Copy .Worksheets(i).Cells
Next
End With

wbNew.ChangeLink Name:=wbOrig.Name, NewName:= _
wbNew.Name, Type:=xlExcelLinks

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Regards,
Peter T

Hi Darren,

Your last loop worked for me in one test just fine (in its own loop, not
sure what you mean by in some other loop). However on re-testing with new
pictures it didn't, seems picture names are not always copied over
consistently (though I would have thought they would with your non-default
named pictures). Anyway, try the following -

For Each ws In wbOrig.Worksheets
Set wsNew = wbNew.Worksheets(ws.Name)
For i = 1 To ws.Pictures.Count
Set picNew = wsNew.Pictures(i)
With ws.Pictures(i)
picNew.Name = .Name
picNew.Width = .Width
picNew.Height = .Height
End With
Next
Next

might be worth testing to see if/ which names need re-naming, eg

if picNew.Name < .Name then
stop
debug.? ws.name; name, wsNew.Name; picNew.Name
picNew.Name = .Name
end if

I'm not sure why you need code to resize any pictures, in light testing they
all copied over with same co-ord's & dimensions.

Regards,
Peter T


"Darren Hill" wrote in message
...
Hi, Peter.

I'm having a problem with the picture code.
After the cells copy loop I added this, and it doesn't appear to do
anything (no error messages either):

i = 0
For Each ws In wbOrig.Worksheets
i = i + 1
Set wsNew = wbNew.Worksheets(i)
' I also tried
'Set wsNew = wbNew.Worksheets(ws.name)
On Error Resume Next
Set shLogo = Nothing
Set shLogo = ws.Shapes("logo1")
On Error GoTo 0
If Not shLogo Is Nothing Then
With wsNew.Shapes("logo1")
.Width = shLogo.Width
.Height = shLogo.Height
End With
End If

On Error Resume Next
Set shLogo = Nothing
Set shLogo = ws.Shapes("logo1")
On Error GoTo 0
If Not shLogo Is Nothing Then
With wsNew.Shapes("logo1")
.Width = shLogo.Width
.Height = shLogo.Height
End With
End If
Next

I then tried the other code, in the same for next loop as above:

For Each ws In wbOrig.Worksheets
Set wsNew = wbNew.Worksheets(ws.name)

For Each picOrig In ws.Pictures
With picOrig
Set picNew = wsNew.Pictures(.Name)
picNew.Width = .Width
picNew.Height = .Height
End With
Next
Next
This also appears to do nothing. Is there something wrong with my for
each loop?
I like this code better than the first, but I'd like it even better if I
could make it work :)

Darren

Peter T wrote:
Hi again,

Firstly, on reflection it might be better to add a separate loop
(worksheets) at the end (after copying over the data) to do the
PageSetUp
stuff. Might be false economy to do it in the first loop.

I haven't pasted your code into the VBE so comments merely after a
'glance'
of your pseudo code

change
Dim shLogo1 as shapes, shLogo2 as Shapes
to
Dim shLogo1 as shape, shLogo2 as Shape

try this

On error resume next
set shLogo1 = nothing
set shLogo1 = wsOrig.shapes("logo1")
on error goto 0
if not shLogo1 is nothing then
with shlogo1
' just as you show below though I image not necessary to change .left &
..top


Another way, air-code

Dim picOrig as Picture, picNew as Picture
for each picOrig in wsOrig.Pictures
with picOrig
set picNew = wsNew.Pictures(.Name)
picNew.Width = .width
picnew.height = .height
end with
next

Regards,
Peter T

"Darren Hill" wrote in message
...
Fantastic, Peter!
I've figured out the pagesetup settings I need and it all works. Yay!
Thanks again.

While you're on a roll :) I have one more question/request:

I've added some pseduo-code below to handle some shapes I have on the
sheets, but I'm not sure how to do a test "Does this shape exist". Can
you look it over and correct my code?
Just so you know: I have two Pictures (Shapes) in the workbook, called
"logo1" and "logo2". There are found in several places and aren#t
always
the same size. Your Copy macro does copy them over, but their sizes
change dramatically. The code below is supposed to te4st if the
pictures
exist in the current worksheet, and correct their sizes if so.

I was thinking of adding a structure like the following in side the
"For Each ws In wbOrig.Worksheets"
loop

'Here's the new stuff
' I'd move the Dims to the top - just here so you can see them.
Dim shLogo1 as shapes, shLogo2 as Shapes
' not sure how to do this next test:
If ws.shapes("logo1").exists then
' once that test works, will the following work okay?
set shlogo1 = wsnew.shapes("logo1")
with shlogo1
.left = ws.shapes("logo1").left
.top = ws.shapes("logo1").top
.width = ws.shapes("logo1").width
.height = ws.shapes("logo1").height
end with
end if
' then repeat for "logo2"
Next


Have I thanked you enough yet? I don't think so: Thanks!

Darren


Peter T wrote:
Hi Darren,

The macro works, but there are two glitches
surely not !

OK, there could be loads of things that don't copy over, as I
mentioned
in
the original thread:

"I should emphasize the macro was quickly put together,
lightly tested and as I said "for ideas". So you will certainly need
to
check the integrity of the new workbook"

Re 1. When done you could try manually Edit replace links or try
'wbNew.ChangeLink' as in the revised macro below.

Re 2. Actual print areas should copy over with the hidden names
"Print_Area". PageSetUp requires more work, how much will depend on
your
needs.

For others looking the original purpose of this macro was to rebuild
what
appeared to be a heavily corrupted workbook of the OP. Therefore
wb.SaveCopyAs would merely duplicate the corruption, potentially so
might
copying over sheets. The macro is still far from complete, it's a one
off
type of thing so add whatever is missing for individual workbooks, eg
Chart
sheets.

Sub WorkBookCopy()
Dim i As Long
Dim ws As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Dim nm As Name
Dim nmNew
Dim wsNew As Worksheet
Dim psOrig As PageSetup
Dim psNew As PageSetup

Application.Calculation = xlCalculationManual
Set wbOrig = ThisWorkbook
Application.SheetsInNewWorkbook = 1
Set wbNew = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each ws In wbOrig.Worksheets
i = i + 1
If i = 1 Then
Set wsNew = wbNew.Worksheets(1)
Else
Set wsNew =
wbNew.Worksheets.Add(after:=wbNew.Worksheets(i -
1))
End If
wsNew.Name = ws.Name
Set psOrig = ws.PageSetup
Set psNew = wsNew.PageSetup

With psOrig
psNew.CenterFooter = .CenterFooter
psNew.CenterHeader = .CenterHeader
psNew.PrintHeadings = .PrintHeadings
' and any others, manually type "psNew."
' and after the dot look at the intellisense
End With
Next

With wbNew.Names
' if not 100% sure the nm.RefersTo string is less than 255
' don't use this (could be a lot more work involved)
For Each nm In wbOrig.Names
.Add nm.Name, nm.RefersTo
Next
End With

Application.DisplayAlerts = False
i = 0
With wbNew
For Each ws In wbOrig.Worksheets
i = i + 1
ws.Cells.Copy .Worksheets(i).Cells
Next
End With

wbNew.ChangeLink Name:=wbOrig.Name, NewName:= _
wbNew.Name, Type:=xlExcelLinks

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Regards,
Peter T

I can't answer this. I assume the whole objective in this thread is to
re-build a corrupted workbook. Maybe you have accidentally stumbled on the
cause of the problem, something relating to those inserted pictures, you say
they need to be re-sized after copying over so perhaps there's a clue there.

Regards,
Peter T

"Darren Hill" wrote in message
...
Something new has come up, Peter.

When running the macro today I get a few error messages AFTER saving the
new file and as I'm closing the original.
The first error is "The picture is too large and will be truncated."

When I click OK, I get the same message again.

When I click OK, I get "Excel cannot complete this task with available
resources. Choose less data or close other applications."

Despite these errors, the macro does complete properly. So I'm not too
concerned (a quick reboot and all should be well) - but do you know what
might be causing them?

Further information:
The error messages didn't happen yesterday, and the workbook I'm
applying the macro to hasn't changed.

I haven't put any shape modifying code in yet, so it's nothing to do
with that.


Thanks,
Darren

Hi, Peter.
The new code had the same effect, but I've figured out what's happening.
The LockAspect setting ratio is on in the original pictures.
For some reason they stretch about 50% when copied, but the height
doesn't change.
Then when your shape/picture altering code is run, the .width command
sets the correct width (but the height shrinks), but then the .height
command puts them back the way they were.

I discovered this when I removed the picnew.height = .height line.

Is there a way to switch off the aspect ratio setting with Pictures? I
know I can do it with shapes, but I prefer the picture version.

Thanks for your help, again.


Peter T wrote:
Hi Darren,

Your last loop worked for me in one test just fine (in its own loop, not
sure what you mean by in some other loop). However on re-testing with new
pictures it didn't, seems picture names are not always copied over
consistently (though I would have thought they would with your non-default
named pictures). Anyway, try the following -

For Each ws In wbOrig.Worksheets
Set wsNew = wbNew.Worksheets(ws.Name)
For i = 1 To ws.Pictures.Count
Set picNew = wsNew.Pictures(i)
With ws.Pictures(i)
picNew.Name = .Name
picNew.Width = .Width
picNew.Height = .Height
End With
Next
Next

might be worth testing to see if/ which names need re-naming, eg

if picNew.Name < .Name then
stop
debug.? ws.name; name, wsNew.Name; picNew.Name
picNew.Name = .Name
end if

I'm not sure why you need code to resize any pictures, in light testing they
all copied over with same co-ord's & dimensions.

Regards,
Peter T


"Darren Hill" wrote in message
...
Hi, Peter.

I'm having a problem with the picture code.
After the cells copy loop I added this, and it doesn't appear to do
anything (no error messages either):

i = 0
For Each ws In wbOrig.Worksheets
i = i + 1
Set wsNew = wbNew.Worksheets(i)
' I also tried
'Set wsNew = wbNew.Worksheets(ws.name)
On Error Resume Next
Set shLogo = Nothing
Set shLogo = ws.Shapes("logo1")
On Error GoTo 0
If Not shLogo Is Nothing Then
With wsNew.Shapes("logo1")
.Width = shLogo.Width
.Height = shLogo.Height
End With
End If

On Error Resume Next
Set shLogo = Nothing
Set shLogo = ws.Shapes("logo1")
On Error GoTo 0
If Not shLogo Is Nothing Then
With wsNew.Shapes("logo1")
.Width = shLogo.Width
.Height = shLogo.Height
End With
End If
Next

I then tried the other code, in the same for next loop as above:

For Each ws In wbOrig.Worksheets
Set wsNew = wbNew.Worksheets(ws.name)

For Each picOrig In ws.Pictures
With picOrig
Set picNew = wsNew.Pictures(.Name)
picNew.Width = .Width
picNew.Height = .Height
End With
Next
Next
This also appears to do nothing. Is there something wrong with my for
each loop?
I like this code better than the first, but I'd like it even better if I
could make it work :)

Darren

Peter T wrote:
Hi again,

Firstly, on reflection it might be better to add a separate loop
(worksheets) at the end (after copying over the data) to do the
PageSetUp
stuff. Might be false economy to do it in the first loop.

I haven't pasted your code into the VBE so comments merely after a
'glance'
of your pseudo code

change
Dim shLogo1 as shapes, shLogo2 as Shapes
to
Dim shLogo1 as shape, shLogo2 as Shape

try this

On error resume next
set shLogo1 = nothing
set shLogo1 = wsOrig.shapes("logo1")
on error goto 0
if not shLogo1 is nothing then
with shlogo1
' just as you show below though I image not necessary to change .left &
.top

Another way, air-code

Dim picOrig as Picture, picNew as Picture
for each picOrig in wsOrig.Pictures
with picOrig
set picNew = wsNew.Pictures(.Name)
picNew.Width = .width
picnew.height = .height
end with
next

Regards,
Peter T

"Darren Hill" wrote in message
...
Fantastic, Peter!
I've figured out the pagesetup settings I need and it all works. Yay!
Thanks again.

While you're on a roll :) I have one more question/request:

I've added some pseduo-code below to handle some shapes I have on the
sheets, but I'm not sure how to do a test "Does this shape exist". Can
you look it over and correct my code?
Just so you know: I have two Pictures (Shapes) in the workbook, called
"logo1" and "logo2". There are found in several places and aren#t
always
the same size. Your Copy macro does copy them over, but their sizes
change dramatically. The code below is supposed to te4st if the
pictures
exist in the current worksheet, and correct their sizes if so.

I was thinking of adding a structure like the following in side the
"For Each ws In wbOrig.Worksheets"
loop

'Here's the new stuff
' I'd move the Dims to the top - just here so you can see them.
Dim shLogo1 as shapes, shLogo2 as Shapes
' not sure how to do this next test:
If ws.shapes("logo1").exists then
' once that test works, will the following work okay?
set shlogo1 = wsnew.shapes("logo1")
with shlogo1
.left = ws.shapes("logo1").left
.top = ws.shapes("logo1").top
.width = ws.shapes("logo1").width
.height = ws.shapes("logo1").height
end with
end if
' then repeat for "logo2"
Next


Have I thanked you enough yet? I don't think so: Thanks!

Darren


Peter T wrote:
Hi Darren,

The macro works, but there are two glitches
surely not !

OK, there could be loads of things that don't copy over, as I
mentioned
in
the original thread:

"I should emphasize the macro was quickly put together,
lightly tested and as I said "for ideas". So you will certainly need
to
check the integrity of the new workbook"

Re 1. When done you could try manually Edit replace links or try
'wbNew.ChangeLink' as in the revised macro below.

Re 2. Actual print areas should copy over with the hidden names
"Print_Area". PageSetUp requires more work, how much will depend on
your
needs.

For others looking the original purpose of this macro was to rebuild
what
appeared to be a heavily corrupted workbook of the OP. Therefore
wb.SaveCopyAs would merely duplicate the corruption, potentially so
might
copying over sheets. The macro is still far from complete, it's a one
off
type of thing so add whatever is missing for individual workbooks, eg
Chart
sheets.

Sub WorkBookCopy()
Dim i As Long
Dim ws As Worksheet
Dim wbOrig As Workbook
Dim wbNew As Workbook
Dim nm As Name
Dim nmNew
Dim wsNew As Worksheet
Dim psOrig As PageSetup
Dim psNew As PageSetup

Application.Calculation = xlCalculationManual
Set wbOrig = ThisWorkbook
Application.SheetsInNewWorkbook = 1
Set wbNew = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each ws In wbOrig.Worksheets
i = i + 1
If i = 1 Then
Set wsNew = wbNew.Worksheets(1)
Else
Set wsNew =
wbNew.Worksheets.Add(after:=wbNew.Worksheets(i -
1))
End If
wsNew.Name = ws.Name
Set psOrig = ws.PageSetup
Set psNew = wsNew.PageSetup

With psOrig
psNew.CenterFooter = .CenterFooter
psNew.CenterHeader = .CenterHeader
psNew.PrintHeadings = .PrintHeadings
' and any others, manually type "psNew."
' and after the dot look at the intellisense
End With
Next

With wbNew.Names
' if not 100% sure the nm.RefersTo string is less than 255
' don't use this (could be a lot more work involved)
For Each nm In wbOrig.Names
.Add nm.Name, nm.RefersTo
Next
End With

Application.DisplayAlerts = False
i = 0
With wbNew
For Each ws In wbOrig.Worksheets
i = i + 1
ws.Cells.Copy .Worksheets(i).Cells
Next
End With

wbNew.ChangeLink Name:=wbOrig.Name, NewName:= _
wbNew.Name, Type:=xlExcelLinks

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Regards,
Peter T

You might be right. But I've just noticed some problems in my browser
when viewing webpages with images in them. Since I've just installed a
new graphic driver, I'm wondering if this error could be related to a
problem with the install. It might not be an excel problem at all. Do
you think that's likely?

Thanks,
Darren

Peter T wrote:
I can't answer this. I assume the whole objective in this thread is to
re-build a corrupted workbook. Maybe you have accidentally stumbled on the
cause of the problem, something relating to those inserted pictures, you say
they need to be re-sized after copying over so perhaps there's a clue there.

Regards,
Peter T

"Darren Hill" wrote in message
...
Something new has come up, Peter.

When running the macro today I get a few error messages AFTER saving the
new file and as I'm closing the original.
The first error is "The picture is too large and will be truncated."

When I click OK, I get the same message again.

When I click OK, I get "Excel cannot complete this task with available
resources. Choose less data or close other applications."

Despite these errors, the macro does complete properly. So I'm not too
concerned (a quick reboot and all should be well) - but do you know what
might be causing them?

Further information:
The error messages didn't happen yesterday, and the workbook I'm
applying the macro to hasn't changed.

I haven't put any shape modifying code in yet, so it's nothing to do
with that.


Thanks,
Darren

If working with the 'old' Picture object
Dim pic as Picture

pic.ShapeRange.LockAspectRatio = msoFalse

I'm not sure if you need to change the property of the original or new
picture but I'm sure you can adapt as required, also not sure if you need to
store the original setting and restore later. Maybe you need to loop
pictures in a loop of all sheets in the original wb before doing the copy
paste - I'll leave that for you to work out.

Regards,
Peter T

"Darren Hill" wrote in message
...
Hi, Peter.
The new code had the same effect, but I've figured out what's happening.
The LockAspect setting ratio is on in the original pictures.
For some reason they stretch about 50% when copied, but the height
doesn't change.
Then when your shape/picture altering code is run, the .width command
sets the correct width (but the height shrinks), but then the .height
command puts them back the way they were.

I discovered this when I removed the picnew.height = .height line.

Is there a way to switch off the aspect ratio setting with Pictures? I
know I can do it with shapes, but I prefer the picture version.

Thanks for your help, again.

Sorry, absolutely no idea !

Regards,
Peter T

"Darren Hill" wrote in message
...
You might be right. But I've just noticed some problems in my browser
when viewing webpages with images in them. Since I've just installed a
new graphic driver, I'm wondering if this error could be related to a
problem with the install. It might not be an excel problem at all. Do
you think that's likely?

Thanks,
Darren

Peter T wrote:
I can't answer this. I assume the whole objective in this thread is to
re-build a corrupted workbook. Maybe you have accidentally stumbled on
the
cause of the problem, something relating to those inserted pictures, you
say
they need to be re-sized after copying over so perhaps there's a clue
there.

Regards,
Peter T
<snip

Hi, Peter.

I changed the new version, inserting that lockaspectratio line (modified
to apply to picNew) just before the width setting line, and it is now
working perfectly.

We got there in the end (OK, you got there in the end :))

Thanks again for all your help.

Darren

Peter T wrote:
If working with the 'old' Picture object
Dim pic as Picture

pic.ShapeRange.LockAspectRatio = msoFalse

I'm not sure if you need to change the property of the original or new
picture but I'm sure you can adapt as required, also not sure if you need to
store the original setting and restore later. Maybe you need to loop
pictures in a loop of all sheets in the original wb before doing the copy
paste - I'll leave that for you to work out.

Regards,
Peter T

"Darren Hill" wrote in message
...
Hi, Peter.
The new code had the same effect, but I've figured out what's happening.
The LockAspect setting ratio is on in the original pictures.
For some reason they stretch about 50% when copied, but the height
doesn't change.
Then when your shape/picture altering code is run, the .width command
sets the correct width (but the height shrinks), but then the .height
command puts them back the way they were.

I discovered this when I removed the picnew.height = .height line.

Is there a way to switch off the aspect ratio setting with Pictures? I
know I can do it with shapes, but I prefer the picture version.

Thanks for your help, again.

Glad it all seems to be working.

I trust this is a one off kind of thing, if not and repeatedly need to
rebuild the same workbook best to get to the route cause of the problem.

Regards,
Peter T

"Darren Hill" wrote in message
...
Hi, Peter.

I changed the new version, inserting that lockaspectratio line (modified
to apply to picNew) just before the width setting line, and it is now
working perfectly.

We got there in the end (OK, you got there in the end :))

Thanks again for all your help.

Darren

Peter T wrote:
If working with the 'old' Picture object
Dim pic as Picture

pic.ShapeRange.LockAspectRatio = msoFalse

I'm not sure if you need to change the property of the original or new
picture but I'm sure you can adapt as required, also not sure if you
need to
store the original setting and restore later. Maybe you need to loop
pictures in a loop of all sheets in the original wb before doing the
copy
paste - I'll leave that for you to work out.

Regards,
Peter T

"Darren Hill" wrote in message
...
Hi, Peter.
The new code had the same effect, but I've figured out what's
happening.
The LockAspect setting ratio is on in the original pictures.
For some reason they stretch about 50% when copied, but the height
doesn't change.
Then when your shape/picture altering code is run, the .width command
sets the correct width (but the height shrinks), but then the .height
command puts them back the way they were.

I discovered this when I removed the picnew.height = .height line.

Is there a way to switch off the aspect ratio setting with Pictures? I
know I can do it with shapes, but I prefer the picture version.

Thanks for your help, again.

Hi, Peter.

The reason for this is a spreadsheet that I've circulated to half a
dozen users, each of whom has their own data to preserve. So, I can now
get their copies back, copy the files into new workbooks, and return to
them (hopefully without the corruption!), and save them the effort of
manually re-entering a lot of data.

I did worry I had two other corrupt workbooks, since they'd been so
unstable when I was editing code, but since installing Excel 2007 SP1,
that instability has completely vanished. I'll still use it with them,
for peace of mind, but it looks in those cases like an Excel 2007 bug
was the problem.

Darren

Peter T wrote:
Glad it all seems to be working.

I trust this is a one off kind of thing, if not and repeatedly need to
rebuild the same workbook best to get to the route cause of the problem.

Regards,
Peter T

"Darren Hill" wrote in message
...
Hi, Peter.

I changed the new version, inserting that lockaspectratio line (modified
to apply to picNew) just before the width setting line, and it is now
working perfectly.

We got there in the end (OK, you got there in the end :))

Thanks again for all your help.

Darren

Peter T wrote:
If working with the 'old' Picture object
Dim pic as Picture

pic.ShapeRange.LockAspectRatio = msoFalse

I'm not sure if you need to change the property of the original or new
picture but I'm sure you can adapt as required, also not sure if you
need to
store the original setting and restore later. Maybe you need to loop
pictures in a loop of all sheets in the original wb before doing the
copy
paste - I'll leave that for you to work out.

Regards,
Peter T

"Darren Hill" wrote in message
...
Hi, Peter.
The new code had the same effect, but I've figured out what's
happening.
The LockAspect setting ratio is on in the original pictures.
For some reason they stretch about 50% when copied, but the height
doesn't change.
Then when your shape/picture altering code is run, the .width command
sets the correct width (but the height shrinks), but then the .height
command puts them back the way they were.

I discovered this when I removed the picnew.height = .height line.

Is there a way to switch off the aspect ratio setting with Pictures? I
know I can do it with shapes, but I prefer the picture version.

Thanks for your help, again.