Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Array Copy - Paste Special Add Help
Thanks!
|
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Can't Copy and Paste or Paste Special between Excel Workbooks | Excel Discussion (Misc queries) | |||
Copy; Paste; Paste Special are disabled | Excel Discussion (Misc queries) | |||
Automating copy/paste/paste special when row references change | Excel Programming | |||
help w/ generic copy & paste/paste special routine | Excel Programming | |||
Dynamic Copy/Paste Special Formulas/Paste Special Values | Excel Programming |