Add a copy/transpose feature
byronwall opened this issue · 8 comments
Just realized that there is not a Copy
equivalent of the Cut/Transpose feature. This need to work in the same way: the entire cell is essentially moved/duplicated without consideration for relative references. This means you cannot just use Copy
to do it.
This should work
Sub copytranspose()
Dim rngSrc As Range
Set rngSrc = Application.InputBox("What range do you want to transpose?", Type:=8)
Dim rRow As Integer
rRow = rngSrc.Rows.Count
Dim rCol As Integer
rCol = rngSrc.Columns.Count
Dim arrTranspose() As Variant
ReDim arrTranspose(1 To rCol, 1 To rRow)
For i = 1 To rRow
For j = 1 To rCol
arrTranspose(j, i) = rngSrc.Cells(i, j)
Next j
Next i
Dim rngDest As Range
Set rngDest = Application.InputBox("Where would you like this to output?", Type:=8)
rngDest.Resize(UBound(arrTranspose, 1), UBound(arrTranspose, 2)).Value = arrTranspose
End Sub
This is a good start. I would add an extra check in there so that it will copy the formula exactly if it has one.
The idea is that there might be a time where you want to copy/transpose a range of cells but not have their formulas update due to the relative shift (changing a column summary to a row summary is a typical example where I have used this). A "normal" copy/transpose will ruin the formulas. This is easy for Cut
since it takes the cell as is and just moves it along with all its references. For this case, I would throw in an extra HasFormula
check where it then reproduces the formula in the new cell if it has a formula. If no formula, then the value is good. (You can use the Formula
for all cases though because it will pull the Value
if there is not an actual Formula
)
One other consideration is that the Cut
version technically works with a discontinuous range since it processes the cells one at a time using a For Each
. This version would overwrite cells in the middle if a discontinuous range was used. This is a bit of an edge case, but I always like to support discontinuous ranges where I can. They come up often enough using SpecialCells
and when filtering ranges and selecting visible cells only (ALT+SEMICOLON).
I suspect pulling the formulas from the cells will require that the cells be processed one by one instead of using the array. I don't think you can output an array of different formulas into a range of cells? In that sense, using the formulas will solve both problems.
Sorry if the intent of this function was not clear from the description. I will get descriptions written up today.
So if the target range was say "A1:A3"&"A5:A7" with the destination being B1 - would it go across column one leaving E1 blank, or shifting to the left?
It would skip E1
and leave a blank so that the source and destination are mirror images of each other.
I believe the blank skipping is the justification for the offset math in the CutPasteTranspose
Sub:
Line 282 in 0c6dd0c
Cut/Paste
logic with the value/formula discussion from above.All right, basing this off cut-transpose -
Sub CopyTranspose()
'If user cancels a range input, we need to handle it when it occurs
On Error GoTo errCancel
Dim rngSelect As Range
Set rngSelect = Selection
Dim rngOut As Range
Set rngOut = Application.InputBox("Select output corner", Type:=8)
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'Application.Calculation = xlCalculationManual
Dim rCorner As Range
Set rCorner = rngSelect.Cells(1, 1)
Dim iCRow As Integer
iCRow = rCorner.Row
Dim iCCol As Integer
iCCol = rCorner.Column
Dim iORow As Integer
Dim iOCol As Integer
iORow = rngOut.Row
iOCol = rngOut.Column
Dim c As Range
For Each c In rngSelect
If Not Intersect(rngSelect, Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow)) Is Nothing Then
MsgBox ("Your destination intersects with your data")
Exit Sub
End If
Next
For Each c In rngSelect
ActiveSheet.Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow).Formula = c.Formula
Next c
'Application.CutCopyMode = False
'Application.ScreenUpdating = True
'Application.EnableEvents = True
'Application.Calculation = xlCalculationAutomatic
'Application.Calculate
errCancel:
End Sub
Is that what we're looking for?
It should be noted that this keeps absolute references, because the data is remaining where it is, even if it's copied.
With cutpastetranspose
the references break if you have any of the referenced cells in your selection.
It might actually be better to use the copytranspose
for cuttranspose
by just c.clearcontents
after doing the copy:
For Each c In rngSelect
ActiveSheet.Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow).Formula = c.Formula
c.ClearContents
Next c
This avoids any of the activation
business as well as doing actual cut & paste - which is slower than doing it directly. It still has references break if they are within the selection.
Wait, I got it
For Each c In rngSelect
c.Copy
ActiveSheet.Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow).PasteSpecial Transpose:=True
c.ClearContents
Next c
For Each c In rngSelect
c.Copy
ActiveSheet.Cells(iORow + c.Column - iCCol, iOCol + c.Row - iCRow).PasteSpecial Transpose:=True
c.ClearContents
Next c
This will change references to be relative with cut/transpose - but that might not be what you want if the cut doesn't include any of the referenced values.
It's almost as if we'd need to loop through each c.formula to see if the references are within rngselect, then decide which way to process it. But, then again, you could reference both inside and outside of the selection. Hmm
That code looks like what I was thinking, and you're right about the absolute references. That's not going to work if the selection includes references inside itself.... hmm. Maybe we just stick to the cut version.
The idea with the copy version is that you could duplicate a data table while transposing rows and columns to flip it around. This might be useful for reporting purposes or making a PivotTable where you don't want to mess with the underlying fields.
This was added in the last sync and can be closed.