M
moonhk
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
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