Pasting Into Multiple Selection

[Bablu]

Hi All-

I found a code online, it works wonderfully. However, I need a help tweaking bit - my vba knowledge is not that advanced.

Below is the code. The only thing I am trying to tweak is that...

If the "PasteRange" has a formula then do not copy to those cells.

I tried multiple things such as PasteRange.Hasformula = True, etc. But I was unable to make it work.

Sub CopyMultipleSelection()
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






Thank you.

 

[Bablu]

What exactly should happen if one of the cells where a paste would go happens to have a formula? Should the value that would have gone to the cell be skipped over or should that value go somewhere else (if yes, where)?

Hi Rick -

The code should skip over the cells that have formulas.

Thanks.

 

[Rick Rothstein]

The code should skip over the cells that have formulas.

I know that... that is not what I asked. Let look at one area from the multiple selection...

A1: One
A2: Two
A3: Three

Let's say that area would go here (the --- indicates a blank cell)...

M7: ---
M8: =X1&Z1
M9: ---

What should happen to the value in cell A2... is it just "lost"? In other words, is this what the copy-to range should look like afterwards...

M7: One
M8: =X1&Z1
M9: Three

 

[Bablu]

Yes, That's it. I would like to keep the formulas intact in the "Pasterange." So, In fact it gets "Lost"

Here is a diagram


[TABLE="width: 280"]
<colgroup><col></colgroup><tbody>[TR]
[TD]Selection Range (1)[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Paste Range (1) - Range with Formula

[/TD]
[/TR]
[TR]
[TD]Formula[/TD]
[/TR]
[TR]
[TD]Formula[/TD]
[/TR]
[TR]
[TD]Formula[/TD]
[/TR]
[TR]
[TD]Result (1)[/TD]
[/TR]
[TR]
[TD]Retain the Formula[/TD]
[/TR]
[TR]
[TD]Retain the Formula[/TD]
[/TR]
[TR]
[TD]Retain the Formula[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Selection Range (2)[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[/TR]
[TR]
[TD="align: right"]8[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[/TR]
[TR]
[TD] [/TD]
[/TR]
[TR]
[TD]Paste Range (2) - Range with Constant Cells[/TD]
[/TR]
[TR]
[TD]Constant Values[/TD]
[/TR]
[TR]
[TD]Constant Values[/TD]
[/TR]
[TR]
[TD]Constant Values[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Result (2)[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[/TR]
[TR]
[TD="align: right"]8[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[/TR]
</tbody>[/TABLE]


Thanks.

 

[Rick Rothstein]

This macro replaces the one you posted in Message #1 and will should do everything you have asked for...

[table="width: 500"]
[tr]
	[td]Sub CopyMultipleSelection()
  Dim StartRow As Long, StartCol As Long, HasData As Boolean
  Dim CopyToCell As Range, Anchor As Range, Ar As Range, Cell As Range
  Set CopyToCell = Application.InputBox("Specify the upper left cell for the paste range:", "Copy Mutliple Selection", Type:=8)
  If TypeName(CopyToCell) <> "Range" Then Exit Sub
  StartRow = Rows.Count
  StartCol = Columns.Count
  On Error Resume Next
  For Each Ar In Selection.Areas
    If Ar(1).Row < StartRow Then StartRow = Ar(1).Row
    If Ar(1).Column < StartCol Then StartCol = Ar(1).Column
    HasData = HasData Or (Ar.SpecialCells(xlConstants).Count > 0)
  Next
  On Error GoTo 0
  If HasData Then If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, "Copy Multiple Selection") <> vbYes Then Exit Sub
  Set Anchor = Cells(StartRow, StartCol)
  For Each Ar In Selection.Areas
    For Each Cell In Ar
      With CopyToCell.Offset(Cell.Row - Anchor.Row, Cell.Column - Anchor.Column)
        If Not .HasFormula Then .Value = Cell.Value
      End With
    Next
  Next
End Sub[/td]
[/tr]
[/table]

 

[Bablu]

Yes, It's working. Thanks again very much!