hi
I have found bits of code from different location on the net. to help
solvinig my issue.
I want to mark rows but only copy and paste some pre slective columns.
but for some reason it doesnt remove the correct columns it look more
like i removes the rows instead.
my code is as following
Sub CopyMultipleSelection()
Dim SelAreas() As Range
Dim PasteRange As Range
Dim UpperLeft As Range
Dim NumAreas As Integer, i As Long
Dim TopRow As Long, LeftCol As Integer
Dim RowOffset As Long, ColOffset As Integer
Dim NonEmptyCellCount As Integer
Dim RemoveColsIndex As Variant
'Define the columns you don't want to copy - here, columns 4 and 14
' remenber to subtract the numbers discarded collumns
RemoveColsIndex = Array(5, 7)
'Columns(F.Column).Hidden = True
' Exit if a range is not selected
If TypeName(Selection) <> "Range" Then
MsgBox "Select the range to be copied. A multiple selection is
allowed."
Exit Sub
End If
' Store the areas as separate Range objects
NumAreas = Selection.Areas.Count
ReDim SelAreas(1 To NumAreas)
For i = 1 To NumAreas
'Selection.SpecialCells(xlCellTypeVisible).Select
If Not IsInArray(RemoveColsIndex, i) Then
Set SelAreas(i) = Selection.Areas(i)
End If
'Set SelAreas(i) = Selection.Areas(i)
Next
' update Store the areas as separate Range objects
NumAreas = UBound(SelAreas)
' Determine the upper left cell in the multiple selection
TopRow = ActiveSheet.Rows.Count
LeftCol = ActiveSheet.Columns.Count
For i = 1 To NumAreas - 1
If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
If SelAreas(i).Column < LeftCol Then LeftCol =
SelAreas(i).Column
Next
Set UpperLeft = Cells(TopRow, LeftCol)
' Get the paste address
On Error Resume Next
Set PasteRange = Application.InputBox _
(Prompt:="Specify the upper left cell for the paste range:", _
Title:="Copy Mutliple Selection", _
Type:=8)
On Error GoTo 0
' Exit if canceled
If TypeName(PasteRange) <> "Range" Then Exit Sub
' Make sure only the upper left cell is used
Set PasteRange = PasteRange.Range("A1")
' Check paste range for existing data
NonEmptyCellCount = 0
For i = 1 To NumAreas - 1
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
NonEmptyCellCount = NonEmptyCellCount + _
Application.CountA(Range(PasteRange.Offset(RowOffset,
ColOffset), _
PasteRange.Offset(RowOffset + SelAreas(i).Rows.Count - 1,
_
ColOffset + SelAreas(i).Columns.Count - 1)))
Next i
' If paste range is not empty, warn user
If NonEmptyCellCount <> 0 Then _
If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _
"Copy Multiple Selection") <> vbYes Then Exit Sub
' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy PasteRange.Offset(i - 1, ColOffset)
Next i
End Sub
Function IsInArray(MyArr As Variant, valueToCheck As Long) As Boolean
Dim iArray As Long
For iArray = LBound(MyArr) To UBound(MyArr)
If valueToCheck = MyArr(iArray) Then
IsInArray = True
Exit Function
End If
Next iArray
InArray = False
End Function
--
----------------------------------------------------------------------------------
Some important links for excel users:
1. Follow us on TWITTER for tips tricks and links :
http://twitter.com/exceldailytip
2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310
3. Excel tutorials at http://www.excel-macros.blogspot.com
4. Learn VBA Macros at http://www.quickvba.blogspot.com
5. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to [email protected]
<><><><><><><><><><><><><><><><><><><><><><>
HELP US GROW !!
We reach over 7000 subscribers worldwide and receive many nice notes about the
learning and support from the group.Let friends and co-workers know they can
subscribe to group at http://groups.google.com/group/excel-macros/subscribe
