Hi Reader

Do you know why selection.* not work ? Need to add "application."
before selection ?


Sub CopySelectedRange()
'~~ By row
Dim a As Range
Dim ThisWB As Workbook
Dim ThisSheet As Worksheet
Dim NewWB As Workbook
Dim NewSheet As Worksheet
Dim ir As Long
Dim ic As Long
Dim TarRow As Long
On Error GoTo cxError

Application.ScreenUpdating = False
Set ThisWB = ActiveWorkbook
Set ThisSheet = ThisWB.ActiveSheet
Set NewWB = Workbooks.Add
Set NewSheet = NewWB.ActiveSheet

ThisSheet.Activate

TarRow = 1
If Application.Selection.Areas.Count = 0 Then
MsgBox "No Area selected"
Exit Sub
Else
MsgBox Application.Selection.Areas.Count
End If

For Each a In Application.Selection.Areas
'MsgBox ir & " " & ic
For ir = 1 To a.Rows.Count
For ic = 1 To a.Columns.Count

NewSheet.Cells(TarRow, ic).Interior.ColorIndex =
a.Cells(ir, ic).Interior.ColorIndex
With NewSheet.Cells(TarRow, ic)
.Value = a.Cells(ir, ic).Value
.NumberFormatLocal = a.Cells(ir, ic).NumberFormatLocal
.Font.ColorIndex = a.Cells(ir, ic).Font.ColorIndex
.Font.Bold = a.Cells(ir, ic).Font.Bold
End With

Next
TarRow = TarRow + 1
Next

Next a

With NewSheet
.Activate
.Cells.Select
.Cells.EntireColumn.AutoFit
.Range("A1").Select
End With
Application.ScreenUpdating = True
Exit Sub


cxError:
Application.ScreenUpdating = True
MsgBox Err.Number & " " & Err.Description

End Sub

I tried the code, with one or multiple selections, and it worked fine.
Protected sheets worked fine also.

--
---
HTH

Bob


(there's no email, no snail mail, but somewhere should be gmail in my addy)



"moonhk" wrote in message
...
Hi Reader

Do you know why selection.* not work ? Need to add "application."
before selection ?


Sub CopySelectedRange()
'~~ By row
Dim a As Range
Dim ThisWB As Workbook
Dim ThisSheet As Worksheet
Dim NewWB As Workbook
Dim NewSheet As Worksheet
Dim ir As Long
Dim ic As Long
Dim TarRow As Long
On Error GoTo cxError

Application.ScreenUpdating = False
Set ThisWB = ActiveWorkbook
Set ThisSheet = ThisWB.ActiveSheet
Set NewWB = Workbooks.Add
Set NewSheet = NewWB.ActiveSheet

ThisSheet.Activate

TarRow = 1
If Application.Selection.Areas.Count = 0 Then
MsgBox "No Area selected"
Exit Sub
Else
MsgBox Application.Selection.Areas.Count
End If

For Each a In Application.Selection.Areas
'MsgBox ir & " " & ic
For ir = 1 To a.Rows.Count
For ic = 1 To a.Columns.Count

NewSheet.Cells(TarRow, ic).Interior.ColorIndex =
a.Cells(ir, ic).Interior.ColorIndex
With NewSheet.Cells(TarRow, ic)
.Value = a.Cells(ir, ic).Value
.NumberFormatLocal = a.Cells(ir, ic).NumberFormatLocal
.Font.ColorIndex = a.Cells(ir, ic).Font.ColorIndex
.Font.Bold = a.Cells(ir, ic).Font.Bold
End With

Next
TarRow = TarRow + 1
Next

Next a

With NewSheet
.Activate
.Cells.Select
.Cells.EntireColumn.AutoFit
.Range("A1").Select
End With
Application.ScreenUpdating = True
Exit Sub


cxError:
Application.ScreenUpdating = True
MsgBox Err.Number & " " & Err.Description

End Sub

'Selection' should work fine without the need to qualify with Application,
though it's not a bad idea to do so.

If Application.Selection.Areas.Count = 0 Then

If the selection is a range of cells Areas.Count will always be at least 1.
Might be better to start with something like -

If Typename(selection) < "Range" then
msgbox "no cells selected" '
exit sub
else
'code to insert new sheet and disable screenupdating
' only after any exit sub, not before as in your posted code
end if

Regards,
Peter T

"moonhk" wrote in message
...
Hi Reader

Do you know why selection.* not work ? Need to add "application."
before selection ?


Sub CopySelectedRange()
'~~ By row
Dim a As Range
Dim ThisWB As Workbook
Dim ThisSheet As Worksheet
Dim NewWB As Workbook
Dim NewSheet As Worksheet
Dim ir As Long
Dim ic As Long
Dim TarRow As Long
On Error GoTo cxError

Application.ScreenUpdating = False
Set ThisWB = ActiveWorkbook
Set ThisSheet = ThisWB.ActiveSheet
Set NewWB = Workbooks.Add
Set NewSheet = NewWB.ActiveSheet

ThisSheet.Activate

TarRow = 1
If Application.Selection.Areas.Count = 0 Then
MsgBox "No Area selected"
Exit Sub
Else
MsgBox Application.Selection.Areas.Count
End If

For Each a In Application.Selection.Areas
'MsgBox ir & " " & ic
For ir = 1 To a.Rows.Count
For ic = 1 To a.Columns.Count

NewSheet.Cells(TarRow, ic).Interior.ColorIndex =
a.Cells(ir, ic).Interior.ColorIndex
With NewSheet.Cells(TarRow, ic)
.Value = a.Cells(ir, ic).Value
.NumberFormatLocal = a.Cells(ir, ic).NumberFormatLocal
.Font.ColorIndex = a.Cells(ir, ic).Font.ColorIndex
.Font.Bold = a.Cells(ir, ic).Font.Bold
End With

Next
TarRow = TarRow + 1
Next

Next a

With NewSheet
.Activate
.Cells.Select
.Cells.EntireColumn.AutoFit
.Range("A1").Select
End With
Application.ScreenUpdating = True
Exit Sub


cxError:
Application.ScreenUpdating = True
MsgBox Err.Number & " " & Err.Description

End Sub

On 12$B7n(B11$BF|(B, $B2<8a(B5$B;~(B11$BJ,(B, "Peter T" <peter_t@discussions wrote:
'Selection' should work fine without the need to qualify with Application,
though it's not a bad idea to do so.

If Application.Selection.Areas.Count = 0 Then

If the selection is a range of cells Areas.Count will always be at least 1.
Might be better to start with something like -

If Typename(selection) < "Range" then
msgbox "no cells selected" '
exit sub
else
'code to insert new sheet and disable screenupdating
' only after any exit sub, not before as in your posted code
end if

Regards,
Peter T

"moonhk" wrote in message

...



Hi Reader

Do you know why selection.* not work ? Need to add "application."
before selection ?

Sub CopySelectedRange()
'~~ By row
Dim a As Range
Dim ThisWB As Workbook
Dim ThisSheet As Worksheet
Dim NewWB As Workbook
Dim NewSheet As Worksheet
Dim ir As Long
Dim ic As Long
Dim TarRow As Long
On Error GoTo cxError

Application.ScreenUpdating = False
Set ThisWB = ActiveWorkbook
Set ThisSheet = ThisWB.ActiveSheet
Set NewWB = Workbooks.Add
Set NewSheet = NewWB.ActiveSheet

ThisSheet.Activate

TarRow = 1
If Application.Selection.Areas.Count = 0 Then
MsgBox "No Area selected"
Exit Sub
Else
MsgBox Application.Selection.Areas.Count
End If

For Each a In Application.Selection.Areas
'MsgBox ir & " " & ic
For ir = 1 To a.Rows.Count
For ic = 1 To a.Columns.Count

NewSheet.Cells(TarRow, ic).Interior.ColorIndex =
a.Cells(ir, ic).Interior.ColorIndex
With NewSheet.Cells(TarRow, ic)
.Value = a.Cells(ir, ic).Value
.NumberFormatLocal = a.Cells(ir, ic).NumberFormatLocal
.Font.ColorIndex = a.Cells(ir, ic).Font.ColorIndex
.Font.Bold = a.Cells(ir, ic).Font.Bold
End With

Next
TarRow = TarRow + 1
Next

Next a

With NewSheet
.Activate
.Cells.Select
.Cells.EntireColumn.AutoFit
.Range("A1").Select
End With
Application.ScreenUpdating = True
Exit Sub

cxError:
Application.ScreenUpdating = True
MsgBox Err.Number & " " & Err.Description

End Sub- $Bp,i6Ho0zMQJ8;z(B -

- $Bp}<(Ho0zMQJ8;z(B -

Thank. Suddenly need to add Application before selection.