Copy/paste ranges

Kunne være således, kommer lidt an på om du vil have alle områder først, derpå kopier, eller som her alle kopier pr område, derpå næste område...


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 intCounter As Integer
Dim intRepCounter As Integer
Dim intRowOffset 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

' ask for repetitions
intCounter = InputBox("Repeat paste # of times:", "Repeat?", 1)
' 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 intRepCounter = 1 To intCounter
    For i = 1 To NumAreas
    RowOffset = SelAreas(i).Row - TopRow + intRowOffset
    ColOffset = SelAreas(i).Column - LeftCol
    SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
    Next i
    intRowOffset = intRowOffset + SelAreas(1).Rows.Count
Next
End Sub

Fantastisk!!! Det virker bare! Mange tak