Need values not formulas - CopyMultipleSelection

[stargazer]

This works great for various worksheets where I am copying ranges that
contain only values. However, in some worksheets, the ranges that I want to
copy contain formulas. I would like to copy the values of those formulas,
not the formulas themselves.


Sub CopyMultipleSelection()

' Copies Fixed Asset Ending Balances for Cost and Accum Depr
' to the Beginning Column
' This will rollover the balances when creating the next years Taxpacks

' CreateRolloverFANameRange

ActiveWorkbook.Names.Add Name:="FAEnding1", _

RefersTo:="='FA-States'!$D$13:$D$23,'FA-States'!$D$32:$D$39,'FA-States'!$G$13:$G$23,'FA-States'!$G$32:$G$39,'FA-States'!$J$13:$J$23,'FA-States'!$J$32:$J$39,'FA-States'!$M$13:$M$23,'FA-States'!$M$32:$M$39", Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding2", _

RefersTo:="='FA-States'!$P$13:$P$23,'FA-States'!$P$32:$P$39,'FA-States'!$S$13:$S$23,'FA-States'!$S$32:$S$39,'FA-States'!$V$13:$V$23,'FA-States'!$V$32:$V$39,'FA-States'!$Y$13:$Y$23,'FA-States'!$Y$32:$Y$39", Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding3", _

RefersTo:="='FA-States'!$AB$13:$AB$23,'FA-States'!$AB$32:$AB$39,'FA-States'!$AE$13:$AE$23,'FA-States'!$AE$32:$AE$39,'FA-States'!$AH$13:$AH$23,'FA-States'!$AH$32:$AH$39,'FA-States'!$AK$13:$AK$23,'FA-States'!$AK$32:$AK$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding4", _

RefersTo:="='FA-States'!$AN$13:$AN$23,'FA-States'!$AN$32:$AN$39,'FA-States'!$AQ$13:$AQ$23,'FA-States'!$AQ$32:$AQ$39,'FA-States'!$AT$13:$AT$23,'FA-States'!$AT$32:$AT$39,'FA-States'!$AW$13:$AW$23,'FA-States'!$AW$32:$AW$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding5", _

RefersTo:="='FA-States'!$AZ$13:$AZ$23,'FA-States'!$AZ$32:$AZ$39,'FA-States'!$BC$13:$BC$23,'FA-States'!$BC$32:$BC$39,'FA-States'!$BF$13:$BF$23,'FA-States'!$BF$32:$BF$39,'FA-States'!$BI$13:$BI$23,'FA-States'!$BI$32:$BI$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding6", _

RefersTo:="='FA-States'!$BL$13:$BL$23,'FA-States'!$BL$32:$BL$39,'FA-States'!$BO$13:$BO$23,'FA-States'!$BO$32:$BO$39,'FA-States'!$BR$13:$BR$23,'FA-States'!$BR$32:$BR$39,'FA-States'!$BU$13:$BU$23,'FA-States'!$BU$32:$BU$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding7", _

RefersTo:="='FA-States'!$BX$13:$BX$23,'FA-States'!$BX$32:$BX$39,'FA-States'!$CA$13:$CA$23,'FA-States'!$CA$32:$CA$39,'FA-States'!$CD$13:$CD$23,'FA-States'!$CD$32:$CD$39,'FA-States'!$CG$13:$CG$23,'FA-States'!$CG$32:$CG$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding8", _

RefersTo:="='FA-States'!$CJ$13:$CJ$23,'FA-States'!$CJ$32:$CJ$39,'FA-States'!$CM$13:$CM$23,'FA-States'!$CM$32:$CM$39,'FA-States'!$CP$13:$CP$23,'FA-States'!$CP$32:$CP$39,'FA-States'!$CS$13:$CS$23,'FA-States'!$CS$32:$CS$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding9", _

RefersTo:="='FA-States'!$CV$13:$CV$23,'FA-States'!$CV$32:$CV$39,'FA-States'!$CY$13:$CY$23,'FA-States'!$CY$32:$CY$39,'FA-States'!$DB$13:$DB$23,'FA-States'!$DB$32:$DB$39,'FA-States'!$DE$13:$DE$23,'FA-States'!$DE$32:$DE$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding10", _

RefersTo:="='FA-States'!$DH$13:$DH$23,'FA-States'!$DH$32:$DH$39,'FA-States'!$DK$13:$DK$23,'FA-States'!$DK$32:$DK$39,'FA-States'!$DN$13:$DN$23,'FA-States'!$DN$32:$DN$39,'FA-States'!$DQ$13:$DQ$23,'FA-States'!$DQ$32:$DQ$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding11", _

RefersTo:="='FA-States'!$DT$13:$DT$23,'FA-States'!$DT$32:$DT$39,'FA-States'!$DW$13:$DW$23,'FA-States'!$DW$32:$DW$39,'FA-States'!$DZ$13:$DZ$23,'FA-States'!$DZ$32:$DZ$39,'FA-States'!$EC$13:$EC$23,'FA-States'!$EC$32:$EC$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding12", _

RefersTo:="='FA-States'!$EF$13:$EF$23,'FA-States'!$EF$32:$EF$39,'FA-States'!$EI$13:$EI$23,'FA-States'!$EI$32:$EI$39,'FA-States'!$EL$13:$EL$23,'FA-States'!$EL$32:$EL$39,'FA-States'!$EO$13:$EO$23,'FA-States'!$EO$32:$EO$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding13", _

RefersTo:="='FA-States'!$ER$13:$ER$23,'FA-States'!$ER$32:$ER$38,'FA-States'!$EU$13:$EU$23,'FA-States'!$EU$32:$EU$39,'FA-States'!$EX$13:$EX$23,'FA-States'!$EX$32:$EX$39,'FA-States'!$FA$13:$FA$23,'FA-States'!$FA$32:$FA$39",
Visible:=True
ActiveWorkbook.Names.Add Name:="FAEnding14",
RefersTo:="='FA-States'!$FD$13:$FD$23,'FA-States'!$FD$32:$FD$39",
Visible:=True

' Selects Various Ranges to be Copied

Union(Range("FAEnding1"), Range("FAEnding2"), Range("FAEnding3"), _
Range("FAEnding4"), Range("FAEnding5"), _
Range("FAEnding6"), Range("FAEnding7"), _
Range("FAEnding8"), Range("FAEnding9"), _
Range("FAEnding10"), Range("FAEnding11"), _
Range("FAEnding12"), Range("FAEnding13"), _
Range("FAEnding14")).Select


'Gets around Excel's default behaviour of not allowing a copy to
'clipboard of non-contiguous ranges

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

' Selection.ClearContents

End Sub

 

[Bernie Deitrick]

Change this part:

' 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


to

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol

'make sure only values are used
SelAreas(i).Copy
PasteRange.Offset(RowOffset, ColOffset).PasteSpecial xlPasteValues
'if you need formats, also use
PasteRange.Offset(RowOffset, ColOffset).PasteSpecial xlPasteFormats

Next i


HTH,
Bernie
MS Excel MVP

 

[stargazer]

That's what I needed.

Thanks Bernie!!!