| Home |
| Search |
| Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Need values not formulas - CopyMultipleSelection
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(RowOffs et, 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 -- Bruce |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Need values not formulas - CopyMultipleSelection
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" wrote in message ... 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(RowOffs et, 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 -- Bruce |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Need values not formulas - CopyMultipleSelection
That's what I needed.
Thanks Bernie!!! -- Bruce "Bernie Deitrick" wrote: 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" wrote in message ... 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(RowOffs et, 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 -- Bruce |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| IF formulas with more than two possible values | Excel Discussion (Misc queries) | |||
| Keep Values and Formulas | Excel Worksheet Functions | |||
| CELLS NOT CALC FORMULAS - VALUES STAY SME FORMULAS CORRECT?? HELP | Excel Worksheet Functions | |||
| values in IF formulas | Excel Worksheet Functions | |||
| AdvancedFilter on cells with formulas, returning values and not formulas | Excel Programming | |||
Linear Mode
