Array Copy - Paste Special Add Help
 

Here is the code I'm working with:

Basically what this allows me to do is copy and paste multiple
selections, but I want to make one tweak to it. I want it to copy,
and them paste special add.

I believe the line of code that is hanging me up is this:

SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)

I'm not sure how to modify it to accumulate another section on top of
it, and not just paste over it. So what I want this to do, is just
keeping adding the same range together as many times as I run the
macro.

Anyone want to take a stab at it?

Thanks,

Tyson


Option Explicit

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 = Range("H10")
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")


' 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

Array Copy - Paste Special Add Help
 

Hi Tyson

Change the line to theese two lines:

SelAreas(i).Copy
PasteRange.Offset(RowOffset, ColOffset).PasteSpecial Operation:=xlAdd

Regards,
Per

On 30 Aug., 00:19, wrote:
Here is the code I'm working with:

Basically what this allows me to do is copy and paste multiple
selections, but I want to make one tweak to it. *I want it to copy,
and them paste special add.

I believe the line of code that is hanging me up is this:

* * * * SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)

I'm not sure how to modify it to accumulate another section on top of
it, and not just paste over it. *So what I want this to do, is just
keeping adding the same range together as many times as I run the
macro.

Anyone want to take a stab at it?

Thanks,

Tyson

Option Explicit

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 = Range("H10")
* * 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")

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

Array Copy - Paste Special Add Help
 

Thanks!