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.

 

[MrTeeny]

I don't think HasFormula works on ranges so you need to loop thru the cells, try something like the following in your code to exit the sub or even just replace the formula. Are you trying to check the range you're posting has a formula or the range you're posting to, so you don't overwrite formulas?

    Dim c As Range
    For Each c In PasteRange
        If c.HasFormula = True Then MsgBox "This range contains a formula"
    Next c

 

[MrKowz]

I don't think HasFormula works on ranges so you need to loop thru the cells, try something like the following in your code to exit the sub or even just replace the formula. Are you trying to check the range you're posting has a formula or the range you're posting to, so you don't overwrite formulas?

    Dim c As Range
    For Each c In PasteRange
        If c.HasFormula = True Then MsgBox "This range contains a formula"
    Next c

HasFormulas may not work, but we can use the SpecialCells method:

Dim c as Range
Set c = Range("A1:A00") 'Replace with your actual range
msgbox c.SpecialCells(xlCellTypeFormulas).Count

This will return the count of cells in the range C that contains a formula. We can test this using an If:

If c.SpecialCells(xlCelLTypeFormulas).Count > 0 Then
     'What we want the code to do if it finds formulas
Else
     'What we want the code to do if it does not find formulas
End If

 

[Bablu]

Thank you guys for the response.

Unfortunately, my problem still remains. I still need to incorporate the code into the original code. I was able to find information on the web, I just could not make it work with the original code.

Would you be able to point out which section(s) of the original code I should change to incorporate the pieces you provided to me?

Thank you.

 

[Bablu]

I don't think HasFormula works on ranges so you need to loop thru the cells, try something like the following in your code to exit the sub or even just replace the formula. Are you trying to check the range you're posting has a formula or the range you're posting to, so you don't overwrite formulas?

    Dim c As Range
    For Each c In PasteRange
        If c.HasFormula = True Then MsgBox "This range contains a formula"
    Next c

MrTeeny - yes, that is correct. If the posting range has formula - I don't want to override the formulas.

Your code is good, but can you please tell me which section I should include this into?

Thanks.

 

[MrTeeny]

Sticking in the same routine as you're checking for blank cells is probably the wisest unless you want to check beforehand or when you're selecting the area. Haven't had time to look thru all your code but you'd simply run thru each cell to see if the HasFormula is true then decide what error routine you want to kick off. I've basically copied the same address you used for the cell count to loop thru to check, you can probably clean that up. I've just added the bit in bold

' 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)))

[B]Dim c As Range[/B]
[B]For Each c In Range(PasteRange.Offset(RowOffset, ColOffset), PasteRange.Offset(RowOffset + SelAreas(I).Rows.Count - 1, ColOffset + SelAreas(I).Columns.Count - 1))[/B]
[B]If c.HasFormula = True Then MsgBox "This range contains a formula"[/B]
[B]Next c[/B]


Next I

 

[Bablu]

Sticking in the same routine as you're checking for blank cells is probably the wisest unless you want to check beforehand or when you're selecting the area. Haven't had time to look thru all your code but you'd simply run thru each cell to see if the HasFormula is true then decide what error routine you want to kick off. I've basically copied the same address you used for the cell count to loop thru to check, you can probably clean that up. I've just added the bit in bold

' 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)))

[B]Dim c As Range[/B]
[B]For Each c In Range(PasteRange.Offset(RowOffset, ColOffset), PasteRange.Offset(RowOffset + SelAreas(I).Rows.Count - 1, ColOffset + SelAreas(I).Columns.Count - 1))[/B]
[B]If c.HasFormula = True Then MsgBox "This range contains a formula"[/B]
[B]Next c[/B]


Next I

Thanks.

if the HasFormula is true then do not paste into those cell.

So the error routine would be not to paste into them. Sorry - I know your code confirms all the cells with formulas, but I still need the other piece.

The other piece being do not paste into the formulas.

 

[MrTeeny]

You can just exit the routine, or skip the the pasting routine by using Goto some label after the paste routine

[B]If c.HasFormula = True Then [/B]Exit Sub

[COLOR=#333333]' Check paste range for existing data[/COLOR]
[COLOR=#333333]..................................................

[/COLOR]Dim c As Range
For Each c In Range(PasteRange.Offset(RowOffset, ColOffset), PasteRange.Offset(RowOffset + SelAreas(I).Rows.Count - 1, ColOffset + SelAreas(I).Columns.Count - 1))
If c.HasFormula = True [/FONT]Then [SIZE=2][COLOR=#333333][I]MsgBox "This range contains a formula exiting routine" : [/I][/COLOR][B]Goto NoPaste[/B][/SIZE]
[FONT=arial]Next c
[COLOR=#333333]Next I[/COLOR]

[COLOR=#333333]' If paste range is not empty, warn user[/COLOR]
[COLOR=#333333]If NonEmptyCellCount <> 0 Then _[/COLOR]
[COLOR=#333333]If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _[/COLOR]
[COLOR=#333333]"Copy Multiple Selection") <> vbYes Then Exit Sub[/COLOR]


[COLOR=#333333]' Copy and paste each area[/COLOR]
[COLOR=#333333]For I = 1 To NumAreas[/COLOR]
[COLOR=#333333]RowOffset = SelAreas(I).Row - TopRow[/COLOR]
[COLOR=#333333]ColOffset = SelAreas(I).Column - LeftCol[/COLOR]
[COLOR=#333333]SelAreas(I).Copy PasteRange.Offset(RowOffset, ColOffset)[/COLOR]
[COLOR=#333333]Next I

[B]NoPaste:
[/B]End Sub
[/COLOR]

but really you should be adding some kind of routine to tell them what to do rather than exiting

 

[Bablu]

You can just exit the routine, or skip the the pasting routine by using Goto some label after the paste routine

[B]If c.HasFormula = True Then [/B]Exit Sub

[COLOR=#333333]' Check paste range for existing data[/COLOR]
[COLOR=#333333]..................................................

[/COLOR]Dim c As Range
For Each c In Range(PasteRange.Offset(RowOffset, ColOffset), PasteRange.Offset(RowOffset + SelAreas(I).Rows.Count - 1, ColOffset + SelAreas(I).Columns.Count - 1))
If c.HasFormula = True

Then [SIZE=2][COLOR=#333333][I]MsgBox "This range contains a formula exiting routine" : [/I][/COLOR][B]Goto NoPaste[/B][/SIZE]
[FONT=arial]Next c
[COLOR=#333333]Next I[/COLOR]

[COLOR=#333333]' If paste range is not empty, warn user[/COLOR]
[COLOR=#333333]If NonEmptyCellCount <> 0 Then _[/COLOR]
[COLOR=#333333]If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _[/COLOR]
[COLOR=#333333]"Copy Multiple Selection") <> vbYes Then Exit Sub[/COLOR]


[COLOR=#333333]' Copy and paste each area[/COLOR]
[COLOR=#333333]For I = 1 To NumAreas[/COLOR]
[COLOR=#333333]RowOffset = SelAreas(I).Row - TopRow[/COLOR]
[COLOR=#333333]ColOffset = SelAreas(I).Column - LeftCol[/COLOR]
[COLOR=#333333]SelAreas(I).Copy PasteRange.Offset(RowOffset, ColOffset)[/COLOR]
[COLOR=#333333]Next I

[B]NoPaste:
[/B]End Sub
[/COLOR][/FONT]

but really you should be adding some kind of routine to tell them what to do rather than exiting

Yes - you are right, "but really you should be adding some kind of routine to tell them what to do rather than exiting". I don't want to exit.

I would like like to skip pasting into the cells with formulas, but paste onto wherever it finds constant cells or cells without formulas. Sorry - I think I shouldv'e mentioned this before.

So still need a bit more help...Thanks!

 

[Rick Rothstein]

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

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)?