Help With Macro Modification

N

New

Hello,

I have this macro which will copy a group of non-contiguous cells to
another sheet. What I would like to know, is it possible to also make it
when it paste to new sheet, paste it as a "paste link". I need to be able to
change info on original sheet, but udate cells on other sheets as a paste
link routine.

Thanks JR


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
 
D

Dave Peterson

I modified the last portion and it seemed to work ok for me:

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy
Application.Goto PasteRange.Offset(RowOffset, ColOffset)
PasteRange.Parent.Paste link:=True
Next i

In fact, to stop the flickering and put things back where they were:

'add to you declaration area
Dim CurSelection As Range
Dim CurActivecell As Range

'and this portion replaces that single portion at the end.
Set CurSelection = Selection
Set CurActivecell = ActiveCell

Application.ScreenUpdating = False

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy
Application.Goto PasteRange.Offset(RowOffset, ColOffset)
PasteRange.Parent.Paste link:=True
Next i

With Application
.Goto CurSelection
CurActivecell.Activate
.ScreenUpdating = True
.CutCopyMode = False
End With
 
N

New

Hello,

I am sorry, but I am real new to this. Am I just adding this to end to
replace what is there? Use this at the end?

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy
Application.Goto PasteRange.Offset(RowOffset, ColOffset)
PasteRange.Parent.Paste link:=True
Next i

When I use this, I get runtime error 400?

Thanks JR
 
D

Dave Peterson

This worked ok for me:

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
Dim CurSelection As Range
Dim CurActivecell As Range

' 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


'and this portion replaces that single portion at the end.
Set CurSelection = Selection
Set CurActivecell = ActiveCell

Application.ScreenUpdating = False

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy
Application.Goto PasteRange.Offset(RowOffset, ColOffset)
PasteRange.Parent.Paste link:=True
Next i

With Application
.Goto CurSelection
CurActivecell.Activate
.ScreenUpdating = True
.CutCopyMode = False
End With

End Sub
 
N

New

Sorry, update. I am using the following, but I get "0" in all empty cells?

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

'add to you declaration area
Dim CurSelection As Range
Dim CurActivecell As Range

'and this portion replaces that single portion at the end.
Set CurSelection = Selection
Set CurActivecell = ActiveCell

Application.ScreenUpdating = False

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy
Application.Goto PasteRange.Offset(RowOffset, ColOffset)
PasteRange.Parent.Paste link:=True
Next i

With Application
.Goto CurSelection
CurActivecell.Activate
.ScreenUpdating = True
.CutCopyMode = False
End With

End Sub


New said:
Hello,

I am sorry, but I am real new to this. Am I just adding this to end to
replace what is there? Use this at the end?

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy
Application.Goto PasteRange.Offset(RowOffset, ColOffset)
PasteRange.Parent.Paste link:=True
Next i

When I use this, I get runtime error 400?

Thanks JR
Click to expand...
 
D

Dave Peterson

this kind of formula:

=sheet1!a1
or even
=A1
will return 0 if the cell is empty.

The usual suggestion is to use a formula like:

=if(a1="","",a1)
or
=if(sheet1!a1="","",sheet1!a1)

But that means that pastelink won't work.

This worked ok for me:
Option Explicit
Sub MyPasteLinks()

Dim SourceRng As Range
Dim SourceTopLeft As Range
Dim DestRng As Range
Dim SourceCell As Range
Dim DestCell As Range
Dim myStr As String

If Not TypeName(Selection) = "Range" Then
Exit Sub
Else
Set SourceRng = Selection
Set SourceTopLeft = SourceRng.Cells(1, 1)
End If

Application.ScreenUpdating = True
On Error Resume Next
Set DestRng = Application.InputBox(prompt:="From: '" _
& Selection.Parent.Name _
& "'!" & Selection.Address _
& vbLf & vbLf _
& "Select the UPPER LEFT CELL of the " _
& "range to which you wish to paste", _
Title:="Copy/Paste Links (kind of)", _
Type:=8)
On Error GoTo 0
Application.ScreenUpdating = False

If DestRng Is Nothing Then
Exit Sub
End If

Set DestRng = DestRng(1)

Application.ScreenUpdating = False

For Each SourceCell In SourceRng.Cells
Set DestCell = Nothing
On Error Resume Next
Set DestCell = DestRng.Offset(SourceCell.Row - SourceTopLeft.Row, _
SourceCell.Column - SourceTopLeft.Column)
On Error GoTo 0
If DestCell Is Nothing Then
MsgBox "Source cell: " & SourceCell.Address(0, 0) & _
" Not copied!" & vbLf & _
"Destination would be off the worksheet!"
Else
myStr = SourceCell.Address(False, False, xlA1, True)
DestCell.Formula = "=if(" & myStr & "="""",""""," & myStr & ")"
End If
Next SourceCell

Application.ScreenUpdating = True

End Sub


New wrote:
<<snipped>>
 
N

New

Runtime 400 error?? The below macro seems to work, but I get the runtime 400
error?

Thanks JR
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
Dim CurSelection As Range
Dim CurActivecell As Range

' 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


'and this portion replaces that single portion at the end.
Set CurSelection = Selection
Set CurActivecell = ActiveCell

Application.ScreenUpdating = False

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy
Application.Goto PasteRange.Offset(RowOffset, ColOffset)
PasteRange.Parent.Paste link:=True
Next i

With Application
.Goto CurSelection
CurActivecell.Activate
.ScreenUpdating = True
.CutCopyMode = False
End With

End Sub
 
D

Dave Peterson

In a simple test, your code worked ok for me.

What line does the code blow up on? What is the address of the selection? What
is the address of the pasted area?
 
N

New

Actually the error is Visual Basic 400 error, sorry. Wierd, everything works
fine?

Thanks JR
 
G

Guest

do you really think that this code is acceptable?

stop using Excel, start using Access

grow up and stop worrying about copying data in a dozen different places
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Copy Multiple Areas from One Workbook to Another 4
Copy Range to Another Workbook 6
Array Copy - Paste Special Add Help 2
Need values not formulas - CopyMultipleSelection 2
Offsetting to identify value in header row 8
advanced filter macro to locate values via multiple criteria 1
Run macro on Active sheet - Columns to rows 8
Invalid Bookmark error 1

Top