Hello,

I have a problem with some code I have and was hoping for some
assistance.

The code below is supose to do the following:
1. Create a dialog box in the current workbook (Centara Feasibility
Study)
2. I select the sheets I would like to export to another (new)
workbook in JPEG format by selecting the checkboxes in the dialog box.
3. Once i press OK the following is supose to happen:
A. A new workbook is created (Centara Feasibility Copy 1.xls)
B. Sheets on the original workbook are copied (if the dialog
check box for that sheet was selected) and are then pasted in the new
workbook as JPEG files.
C. Just prior to this the macro is supose to add a new worksheet
in the 'Copy 1' workbook and rename the sheet (the new name for the
sheet is supose to be the same name as the sheet where the original
was copied from).

Thats it...except for a bug I cannot for the life of me figure out
what to do.
The bug is somewhere in the selecting of the sheets to copy and the
nameing of the new worksheets.

Any help on this would be appreciated.
Thanks
Tim


Sub Export_Sheets()

Dim mypass As String

Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim PrintDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim CB As CheckBox
Application.ScreenUpdating = False

' Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If

' Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add

SheetCount = 0

' Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
' Skip empty sheets sheets
If Application.CountA(CurrentSheet.Cells) = 0 Then
SheetCount = SheetCount + 1
PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
PrintDlg.CheckBoxes(SheetCount).text = _
CurrentSheet.Name
If Worksheets(i).Visible < xlSheetVisible Then
PrintDlg.CheckBoxes(SheetCount).Value = True
End If
TopPos = TopPos + 13
End If
Next i

' Move the OK and Cancel buttons
PrintDlg.Buttons.Left = 240

' Set dialog height, width, and caption
With PrintDlg.DialogFrame
.Height = Application.Max _
(68, PrintDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to export"
End With

' Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
PrintDlg.Buttons("Button 2").BringToFront
PrintDlg.Buttons("Button 3").BringToFront

' Display the dialog box
CurrentSheet.Activate
Application.ScreenUpdating = True
If SheetCount < 0 Then
If PrintDlg.Show Then
Workbooks.Add
ChDir "C:\Documents and Settings\Em\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Em\Desktop\Centara
Feasibility Copy 1.xls", _
ReadOnlyRecommended:=False, CreateBackup:=False
For Each CB In PrintDlg.CheckBoxes
Worksheets(CB.Caption).Activate
If CB.Value = xlOn Then
Windows("Centara Feasibility Study
Tool.xls").Activate
Sheets(CB.SheetCount.text).Select
Range("A1:X163").Select
Range("A1:X163").Copy
Windows("Centara Feasibility Copy 1.xls").Activate
Sheets.Add
Sheets(ActiveSheet).Name =
PrintDlg.CheckBoxes(SheetCount).text
Range("A1").Select
ActiveSheet.Pictures.Paste.Select
Selection.ShapeRange.ZOrder msoSendToBack
Range("A1").Select
Application.CutCopyMode = False
Else
ActiveSheet.Visible = xlSheetVisible
End If
Next CB
End If
Else
MsgBox "All worksheets are empty."
End If

' Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
PrintDlg.Delete

' Reactivate original sheet
Cover.Activate
End Sub

Tim,
There is no "Pictures" collection in Excel. Hence, your Paste is going to
fail.
Why do need it in jpeg format if you are pasting a range into a workbook ?

NickHK

"Tim" wrote in message
m...
Hello,

I have a problem with some code I have and was hoping for some
assistance.

The code below is supose to do the following:
1. Create a dialog box in the current workbook (Centara Feasibility
Study)
2. I select the sheets I would like to export to another (new)
workbook in JPEG format by selecting the checkboxes in the dialog box.
3. Once i press OK the following is supose to happen:
A. A new workbook is created (Centara Feasibility Copy 1.xls)
B. Sheets on the original workbook are copied (if the dialog
check box for that sheet was selected) and are then pasted in the new
workbook as JPEG files.
C. Just prior to this the macro is supose to add a new worksheet
in the 'Copy 1' workbook and rename the sheet (the new name for the
sheet is supose to be the same name as the sheet where the original
was copied from).

Thats it...except for a bug I cannot for the life of me figure out
what to do.
The bug is somewhere in the selecting of the sheets to copy and the
nameing of the new worksheets.

Any help on this would be appreciated.
Thanks
Tim


Sub Export_Sheets()

Dim mypass As String

Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim PrintDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim CB As CheckBox
Application.ScreenUpdating = False

' Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If

' Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add

SheetCount = 0

' Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
' Skip empty sheets sheets
If Application.CountA(CurrentSheet.Cells) = 0 Then
SheetCount = SheetCount + 1
PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
PrintDlg.CheckBoxes(SheetCount).text = _
CurrentSheet.Name
If Worksheets(i).Visible < xlSheetVisible Then
PrintDlg.CheckBoxes(SheetCount).Value = True
End If
TopPos = TopPos + 13
End If
Next i

' Move the OK and Cancel buttons
PrintDlg.Buttons.Left = 240

' Set dialog height, width, and caption
With PrintDlg.DialogFrame
.Height = Application.Max _
(68, PrintDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to export"
End With

' Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
PrintDlg.Buttons("Button 2").BringToFront
PrintDlg.Buttons("Button 3").BringToFront

' Display the dialog box
CurrentSheet.Activate
Application.ScreenUpdating = True
If SheetCount < 0 Then
If PrintDlg.Show Then
Workbooks.Add
ChDir "C:\Documents and Settings\Em\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Em\Desktop\Centara
Feasibility Copy 1.xls", _
ReadOnlyRecommended:=False, CreateBackup:=False
For Each CB In PrintDlg.CheckBoxes
Worksheets(CB.Caption).Activate
If CB.Value = xlOn Then
Windows("Centara Feasibility Study
Tool.xls").Activate
Sheets(CB.SheetCount.text).Select
Range("A1:X163").Select
Range("A1:X163").Copy
Windows("Centara Feasibility Copy 1.xls").Activate
Sheets.Add
Sheets(ActiveSheet).Name =
PrintDlg.CheckBoxes(SheetCount).text
Range("A1").Select
ActiveSheet.Pictures.Paste.Select
Selection.ShapeRange.ZOrder msoSendToBack
Range("A1").Select
Application.CutCopyMode = False
Else
ActiveSheet.Visible = xlSheetVisible
End If
Next CB
End If
Else
MsgBox "All worksheets are empty."
End If

' Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
PrintDlg.Delete

' Reactivate original sheet
Cover.Activate
End Sub

Dear NickHK

I can do this copy / paste picture manually by:
1. selecting the range
2. selecting EDIT COPY
3. selecting the new WB and range A1
4. holding down the SHIFT key select EDIT Paste Picture

I want to do the same in a macro as below but through a dialog box.
All on Excel XP

Regards
Tim


NickHK" wrote in message ...
Tim,
There is no "Pictures" collection in Excel. Hence, your Paste is going to
fail.
Why do need it in jpeg format if you are pasting a range into a workbook ?

NickHK

"Tim" wrote in message
m...
Hello,

I have a problem with some code I have and was hoping for some
assistance.

The code below is supose to do the following:
1. Create a dialog box in the current workbook (Centara Feasibility
Study)
2. I select the sheets I would like to export to another (new)
workbook in JPEG format by selecting the checkboxes in the dialog box.
3. Once i press OK the following is supose to happen:
A. A new workbook is created (Centara Feasibility Copy 1.xls)
B. Sheets on the original workbook are copied (if the dialog
check box for that sheet was selected) and are then pasted in the new
workbook as JPEG files.
C. Just prior to this the macro is supose to add a new worksheet
in the 'Copy 1' workbook and rename the sheet (the new name for the
sheet is supose to be the same name as the sheet where the original
was copied from).

Thats it...except for a bug I cannot for the life of me figure out
what to do.
The bug is somewhere in the selecting of the sheets to copy and the
nameing of the new worksheets.

Any help on this would be appreciated.
Thanks
Tim


Sub Export_Sheets()

Dim mypass As String

Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim PrintDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim CB As CheckBox
Application.ScreenUpdating = False

' Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If

' Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add

SheetCount = 0

' Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
' Skip empty sheets sheets
If Application.CountA(CurrentSheet.Cells) = 0 Then
SheetCount = SheetCount + 1
PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
PrintDlg.CheckBoxes(SheetCount).text = _
CurrentSheet.Name
If Worksheets(i).Visible < xlSheetVisible Then
PrintDlg.CheckBoxes(SheetCount).Value = True
End If
TopPos = TopPos + 13
End If
Next i

' Move the OK and Cancel buttons
PrintDlg.Buttons.Left = 240

' Set dialog height, width, and caption
With PrintDlg.DialogFrame
.Height = Application.Max _
(68, PrintDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to export"
End With

' Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
PrintDlg.Buttons("Button 2").BringToFront
PrintDlg.Buttons("Button 3").BringToFront

' Display the dialog box
CurrentSheet.Activate
Application.ScreenUpdating = True
If SheetCount < 0 Then
If PrintDlg.Show Then
Workbooks.Add
ChDir "C:\Documents and Settings\Em\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Em\Desktop\Centara
Feasibility Copy 1.xls", _
ReadOnlyRecommended:=False, CreateBackup:=False
For Each CB In PrintDlg.CheckBoxes
Worksheets(CB.Caption).Activate
If CB.Value = xlOn Then
Windows("Centara Feasibility Study
Tool.xls").Activate
Sheets(CB.SheetCount.text).Select
Range("A1:X163").Select
Range("A1:X163").Copy
Windows("Centara Feasibility Copy 1.xls").Activate
Sheets.Add
Sheets(ActiveSheet).Name =
PrintDlg.CheckBoxes(SheetCount).text
Range("A1").Select
ActiveSheet.Pictures.Paste.Select
Selection.ShapeRange.ZOrder msoSendToBack
Range("A1").Select
Application.CutCopyMode = False
Else
ActiveSheet.Visible = xlSheetVisible
End If
Next CB
End If
Else
MsgBox "All worksheets are empty."
End If

' Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
PrintDlg.Delete

' Reactivate original sheet
Cover.Activate
End Sub

Tim,
Sorry, never knew you could do that.
If you look at the help on "Pictures", you'll see it's a hidden collection
and Shapes collection is recommended to be used.
That not your problem though.

I'll see what I can do to help.

NickHK


"Tim" wrote in message
om...
Dear NickHK

I can do this copy / paste picture manually by:
1. selecting the range
2. selecting EDIT COPY
3. selecting the new WB and range A1
4. holding down the SHIFT key select EDIT Paste Picture

I want to do the same in a macro as below but through a dialog box.
All on Excel XP

Regards
Tim


NickHK" wrote in message
...
Tim,
There is no "Pictures" collection in Excel. Hence, your Paste is going
to
fail.
Why do need it in jpeg format if you are pasting a range into a workbook
?

NickHK

"Tim" wrote in message
m...
Hello,

I have a problem with some code I have and was hoping for some
assistance.

The code below is supose to do the following:
1. Create a dialog box in the current workbook (Centara Feasibility
Study)
2. I select the sheets I would like to export to another (new)
workbook in JPEG format by selecting the checkboxes in the dialog box.
3. Once i press OK the following is supose to happen:
A. A new workbook is created (Centara Feasibility Copy 1.xls)
B. Sheets on the original workbook are copied (if the dialog
check box for that sheet was selected) and are then pasted in the new
workbook as JPEG files.
C. Just prior to this the macro is supose to add a new worksheet
in the 'Copy 1' workbook and rename the sheet (the new name for the
sheet is supose to be the same name as the sheet where the original
was copied from).

Thats it...except for a bug I cannot for the life of me figure out
what to do.
The bug is somewhere in the selecting of the sheets to copy and the
nameing of the new worksheets.

Any help on this would be appreciated.
Thanks
Tim


Sub Export_Sheets()

Dim mypass As String

Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim PrintDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim CB As CheckBox
Application.ScreenUpdating = False

' Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If

' Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add

SheetCount = 0

' Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
' Skip empty sheets sheets
If Application.CountA(CurrentSheet.Cells) = 0 Then
SheetCount = SheetCount + 1
PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
PrintDlg.CheckBoxes(SheetCount).text = _
CurrentSheet.Name
If Worksheets(i).Visible < xlSheetVisible Then
PrintDlg.CheckBoxes(SheetCount).Value = True
End If
TopPos = TopPos + 13
End If
Next i

' Move the OK and Cancel buttons
PrintDlg.Buttons.Left = 240

' Set dialog height, width, and caption
With PrintDlg.DialogFrame
.Height = Application.Max _
(68, PrintDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to export"
End With

' Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
PrintDlg.Buttons("Button 2").BringToFront
PrintDlg.Buttons("Button 3").BringToFront

' Display the dialog box
CurrentSheet.Activate
Application.ScreenUpdating = True
If SheetCount < 0 Then
If PrintDlg.Show Then
Workbooks.Add
ChDir "C:\Documents and Settings\Em\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Em\Desktop\Centara
Feasibility Copy 1.xls", _
ReadOnlyRecommended:=False, CreateBackup:=False
For Each CB In PrintDlg.CheckBoxes
Worksheets(CB.Caption).Activate
If CB.Value = xlOn Then
Windows("Centara Feasibility Study
Tool.xls").Activate
Sheets(CB.SheetCount.text).Select
Range("A1:X163").Select
Range("A1:X163").Copy
Windows("Centara Feasibility Copy 1.xls").Activate
Sheets.Add
Sheets(ActiveSheet).Name =
PrintDlg.CheckBoxes(SheetCount).text
Range("A1").Select
ActiveSheet.Pictures.Paste.Select
Selection.ShapeRange.ZOrder msoSendToBack
Range("A1").Select
Application.CutCopyMode = False
Else
ActiveSheet.Visible = xlSheetVisible
End If
Next CB
End If
Else
MsgBox "All worksheets are empty."
End If

' Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
PrintDlg.Delete

' Reactivate original sheet
Cover.Activate
End Sub

Thanks NickHK,

I look forward to yours, and anyone else that could shead some light on this.
I am really stuck on this one.
Regards
Tim

"NickHK" wrote in message ...
Tim,
Sorry, never knew you could do that.
If you look at the help on "Pictures", you'll see it's a hidden collection
and Shapes collection is recommended to be used.
That not your problem though.

I'll see what I can do to help.

NickHK


"Tim" wrote in message
om...
Dear NickHK

I can do this copy / paste picture manually by:
1. selecting the range
2. selecting EDIT COPY
3. selecting the new WB and range A1
4. holding down the SHIFT key select EDIT Paste Picture

I want to do the same in a macro as below but through a dialog box.
All on Excel XP

Regards
Tim


NickHK" wrote in message
...
Tim,
There is no "Pictures" collection in Excel. Hence, your Paste is going
to
fail.
Why do need it in jpeg format if you are pasting a range into a workbook
?

NickHK

"Tim" wrote in message
m...
Hello,

I have a problem with some code I have and was hoping for some
assistance.

The code below is supose to do the following:
1. Create a dialog box in the current workbook (Centara Feasibility
Study)
2. I select the sheets I would like to export to another (new)
workbook in JPEG format by selecting the checkboxes in the dialog box.
3. Once i press OK the following is supose to happen:
A. A new workbook is created (Centara Feasibility Copy 1.xls)
B. Sheets on the original workbook are copied (if the dialog
check box for that sheet was selected) and are then pasted in the new
workbook as JPEG files.
C. Just prior to this the macro is supose to add a new worksheet
in the 'Copy 1' workbook and rename the sheet (the new name for the
sheet is supose to be the same name as the sheet where the original
was copied from).

Thats it...except for a bug I cannot for the life of me figure out
what to do.
The bug is somewhere in the selecting of the sheets to copy and the
nameing of the new worksheets.

Any help on this would be appreciated.
Thanks
Tim


Sub Export_Sheets()

Dim mypass As String

Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim PrintDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim CB As CheckBox
Application.ScreenUpdating = False

' Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If

' Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add

SheetCount = 0

' Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
' Skip empty sheets sheets
If Application.CountA(CurrentSheet.Cells) = 0 Then
SheetCount = SheetCount + 1
PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
PrintDlg.CheckBoxes(SheetCount).text = _
CurrentSheet.Name
If Worksheets(i).Visible < xlSheetVisible Then
PrintDlg.CheckBoxes(SheetCount).Value = True
End If
TopPos = TopPos + 13
End If
Next i

' Move the OK and Cancel buttons
PrintDlg.Buttons.Left = 240

' Set dialog height, width, and caption
With PrintDlg.DialogFrame
.Height = Application.Max _
(68, PrintDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to export"
End With

' Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
PrintDlg.Buttons("Button 2").BringToFront
PrintDlg.Buttons("Button 3").BringToFront

' Display the dialog box
CurrentSheet.Activate
Application.ScreenUpdating = True
If SheetCount < 0 Then
If PrintDlg.Show Then
Workbooks.Add
ChDir "C:\Documents and Settings\Em\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Em\Desktop\Centara
Feasibility Copy 1.xls", _
ReadOnlyRecommended:=False, CreateBackup:=False
For Each CB In PrintDlg.CheckBoxes
Worksheets(CB.Caption).Activate
If CB.Value = xlOn Then
Windows("Centara Feasibility Study
Tool.xls").Activate
Sheets(CB.SheetCount.text).Select
Range("A1:X163").Select
Range("A1:X163").Copy
Windows("Centara Feasibility Copy 1.xls").Activate
Sheets.Add
Sheets(ActiveSheet).Name =
PrintDlg.CheckBoxes(SheetCount).text
Range("A1").Select
ActiveSheet.Pictures.Paste.Select
Selection.ShapeRange.ZOrder msoSendToBack
Range("A1").Select
Application.CutCopyMode = False
Else
ActiveSheet.Visible = xlSheetVisible
End If
Next CB
End If
Else
MsgBox "All worksheets are empty."
End If

' Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
PrintDlg.Delete

' Reactivate original sheet
Cover.Activate
End Sub

Tim,
This works for me.

NickHK

Sub Export_Sheets()

Dim mypass As String

Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim PrintDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim CB As CheckBox
'Application.ScreenUpdating = False

' Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If

' Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add

SheetCount = 0

' Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
' Skip empty sheets sheets
If Application.CountA(CurrentSheet.Cells) = 0 Then
SheetCount = SheetCount + 1
PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
PrintDlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
If Worksheets(i).Visible < xlSheetVisible Then
PrintDlg.CheckBoxes(SheetCount).Value = True
End If
TopPos = TopPos + 13
End If
Next i

' Move the OK and Cancel buttons
PrintDlg.Buttons.Left = 240

' Set dialog height, width, and caption
With PrintDlg.DialogFrame
.Height = Application.Max _
(68, PrintDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to export"
End With

' Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
PrintDlg.Buttons("Button 2").BringToFront
PrintDlg.Buttons("Button 3").BringToFront

' Display the dialog box
'''' CurrentSheet.Activate
Application.ScreenUpdating = True
If SheetCount < 0 Then
If PrintDlg.Show Then
Workbooks.Add
' ChDir "C:\Documents and Settings\Em\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Nick\Desktop\Centara Feasibility
Copy 1.xls", _
ReadOnlyRecommended:=False, CreateBackup:=False
For Each CB In PrintDlg.CheckBoxes
If CB.Value = xlOn Then
Workbooks("Book4.xls").Activate
Worksheets(CB.Caption).Activate

'Workbooks("Book4.xls").Activate
'Sheets(CB.SheetCount.Text).Select
Range("A1:H30").Select
Range("A1:H30").Copy
Workbooks("Centara Feasibility Copy 1.xls").Activate
Sheets.Add
''''' Sheets(ActiveSheet).Name =
PrintDlg.CheckBoxes(SheetCount).Text
''''' ActiveSheet.Name =
PrintDlg.CheckBoxes(SheetCount).Text

''''' Range("A1").Select
ActiveSheet.Pictures.Paste.Select
Selection.ShapeRange.ZOrder msoSendToBack
Range("A1").Select
Application.CutCopyMode = False
Else
ActiveSheet.Visible = xlSheetVisible
End If
Next CB
End If
Else
MsgBox "All worksheets are empty."
End If

' Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False

Workbooks("Book4.xls").Sheets(PrintDlg.Name).Delet e

' Reactivate original sheet
Cover.Activate
End Sub

Thanks for all your help Nick.
Regards
Tim

"NickHK" wrote in message ...
Tim,
This works for me.

NickHK

Sub Export_Sheets()

Dim mypass As String

Dim i As Integer
Dim TopPos As Integer
Dim SheetCount As Integer
Dim PrintDlg As DialogSheet
Dim CurrentSheet As Worksheet
Dim CB As CheckBox
'Application.ScreenUpdating = False

' Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If

' Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set PrintDlg = ActiveWorkbook.DialogSheets.Add

SheetCount = 0

' Add the checkboxes
TopPos = 40
For i = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(i)
' Skip empty sheets sheets
If Application.CountA(CurrentSheet.Cells) = 0 Then
SheetCount = SheetCount + 1
PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
PrintDlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
If Worksheets(i).Visible < xlSheetVisible Then
PrintDlg.CheckBoxes(SheetCount).Value = True
End If
TopPos = TopPos + 13
End If
Next i

' Move the OK and Cancel buttons
PrintDlg.Buttons.Left = 240

' Set dialog height, width, and caption
With PrintDlg.DialogFrame
.Height = Application.Max _
(68, PrintDlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to export"
End With

' Change tab order of OK and Cancel buttons
' so the 1st option button will have the focus
PrintDlg.Buttons("Button 2").BringToFront
PrintDlg.Buttons("Button 3").BringToFront

' Display the dialog box
'''' CurrentSheet.Activate
Application.ScreenUpdating = True
If SheetCount < 0 Then
If PrintDlg.Show Then
Workbooks.Add
' ChDir "C:\Documents and Settings\Em\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Nick\Desktop\Centara Feasibility
Copy 1.xls", _
ReadOnlyRecommended:=False, CreateBackup:=False
For Each CB In PrintDlg.CheckBoxes
If CB.Value = xlOn Then
Workbooks("Book4.xls").Activate
Worksheets(CB.Caption).Activate

'Workbooks("Book4.xls").Activate
'Sheets(CB.SheetCount.Text).Select
Range("A1:H30").Select
Range("A1:H30").Copy
Workbooks("Centara Feasibility Copy 1.xls").Activate
Sheets.Add
''''' Sheets(ActiveSheet).Name =
PrintDlg.CheckBoxes(SheetCount).Text
''''' ActiveSheet.Name =
PrintDlg.CheckBoxes(SheetCount).Text

''''' Range("A1").Select
ActiveSheet.Pictures.Paste.Select
Selection.ShapeRange.ZOrder msoSendToBack
Range("A1").Select
Application.CutCopyMode = False
Else
ActiveSheet.Visible = xlSheetVisible
End If
Next CB
End If
Else
MsgBox "All worksheets are empty."
End If

' Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False

Workbooks("Book4.xls").Sheets(PrintDlg.Name).Delet e

' Reactivate original sheet
Cover.Activate
End Sub