I'm trying to write a macro to copy info from two cells and paste it into
another Sheet named ToDo transposed and in the first available cell in Col A.
The cells I want to copy are the equivalent of R2C and RC so if I'm in cell
D34 then I would get D2 and D34 copied into A1 and B1 on ToDo Sheet assuming
it was empty.
I'm fine with the pasting part of the macro but whatever I try to select and
copy the non contiguous cells returns an error so I would appreciate some
help with the coding to do this.
Many thanks
This maybe a repeated post, my apologies if it is, I think I buggered
it up the first time, sorry Monday morning and the coffee has not
kicked in yet
))
I found this code on John Walkenbach's excel site, and will allow the
user to select non-contiguous cells, and paste them back to where ever
in the workbook. Bear in mind the code sometimes screws up when pasted
here. Hope it helps
Sub CopyMultipleSelection()
'Gets around Excel's default behaviour of not allowing a copy to
'clipboard of non-contiguous ranges
Dim SelAreas() As Range
Dim PasteRange As Range
Dim UpperLeft As Range
Dim NumAreas As Integer, i As Integer
Dim TopRow As Long, LeftCol As Integer
Dim RowOffset As Long, ColOffset As Integer
Dim NonEmptyCellCount As Integer
' 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
Set SelAreas(i) = Selection.Areas(i)
Next
' Determine the upper left cell in the multiple selection
TopRow = ActiveSheet.Rows.Count
LeftCol = ActiveSheet.Columns.Count
For i = 1 To NumAreas
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
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(RowOffset, ColOffset)
Next i
End Sub
