Craig,
If you only want to paste data, copy the range and then
paste special>transpose
If you want to paste keeping the links to the original
data you can:
1. Use TRANSPOSE function (wich has to be array-entered.
ctrl+shift+enter)
2. Use macro written by Bernie Deitrick:
Sub TranposeLinks()
'Written by Bernie Deitrick 12/12/2001
'With a lot of help from J.E. McGimpsey and John Walkenbach
Const PROJ_TITLE As String = "Transpose Link Paster"
Dim myRange As Range
Dim myCell As Range
Dim myCell2 As Range
Dim i As Integer
Dim j As Integer
Dim myWorkbook As Workbook
Dim myWorksheet As Worksheet
Dim PrefixString As String
Dim ErrString As String
Dim CalcMode As Integer
On Error GoTo ErrHandler
' JW's #4. If the original selection is not a Range
' If so, the first set statement will
' raise the following error message:
ErrString = "You need to start with a cell " & _
Chr(10) & "or range of cells selected."
Set myRange = Selection
Set myWorksheet = ActiveSheet
Set myWorkbook = ActiveWorkbook
' JW's #2. The user starts with a multiple selection.
' Raise the error with the following message
ErrString = "You can only transpose-link a contiguous
block of cells."
If myRange.Areas.Count > 1 Then Err.Raise 1
' JW's #5. The selection consists of an entire column or
columns
' Raise the error with the following message
ErrString = "You can only transpose-link up to 256 rows."
If myRange.Rows.Count > 256 Then Err.Raise 1
Do
Set myCell = Application.InputBox( _
"Select the anchor cell for the transposed links.", _
Title:=PROJ_TITLE, Type:=8)
On Error GoTo 0
'For poor selection of the anchor cell, use message
boxes to inform,
'then set the myCell range object to nothing to
prevent further
'processing and to eventually return to the top of the
Do Loop.
' JW's #6. The user selects more than one cell in the
InputBox
' Offer to use the first cell
If Not myCell Is Nothing Then
If myCell.Cells.Count > 1 Then
If MsgBox("Do you want to use " & _
myCell.Cells(1, 1).Address(False, False) &
_
" as the anchor point?", _
vbYesNo, Title:=PROJ_TITLE) = vbNo Then
Set myCell = Nothing
Else
Set myCell = myCell(1, 1)
End If
End If
End If
' JW's #8. You run out of columns when transposing a
vertical range.
' Check for adequate columns
If Not myCell Is Nothing Then
If myCell.Column - 1 + myRange.Rows.Count > 256
Then
MsgBox "You need to select an anchor cell with
enough columns to the right"
Set myCell = Nothing
End If
End If
' JW's #7. The destination range overlaps
' with the source range (circ ref error)
' Check for overlap of ranges if on the same worksheet
If Not myCell Is Nothing Then
If myCell.Parent Is myRange.Parent Then
If Not Intersect(myCell.Resize
(myRange.Columns.Count, _
myRange.Rows.Count), myRange) Is
Nothing Then
MsgBox "Your transposed output will " & _
"overlap your original selection." &
Chr(10) & _
"Please select another anchor cell.", _
vbOKOnly, PROJ_TITLE
Set myCell = Nothing
End If
End If
End If
' JW's #1. The destination range is protected.
' JW's #3. The destination sheet is protected.
' #1 is only important if #3 is true.
' If it is, check for locked cells.
If Not myCell Is Nothing Then
If myCell.Parent.ProtectContents = True Then
For Each myCell2 In myCell.Resize( _
myRange.Columns.Count, myRange.Rows.Count)
If myCell2.Locked = True Then
Set myCell = Nothing
End If
Next myCell2
End If
If myCell Is Nothing Then
MsgBox "One or more of the destination " & _
"cells are currently protected." & _
Chr(10) & "Please select unlocked cells
only, " & _
"or cells on an unprotected sheet.", _
vbOKOnly, PROJ_TITLE
End If
End If
'Check for filled cells
'My only original anchor cell check
'Of course, it is the least important
If Not myCell Is Nothing Then
If Application.WorksheetFunction.CountBlank
(myCell.Resize(myRange.Columns.Count, myRange.Rows.Count))
<> myRange.Cells.Count Then
If MsgBox("Do you want to overwrite the
existing cells?", _
vbYesNo, PROJ_TITLE) = vbNo Then
Set myCell = Nothing
End If
End If
End If
On Error GoTo ErrHandler
Loop Until Not myCell Is Nothing
With Application
.ScreenUpdating = False
'Preserve calc mode before turning off cals
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With
' Tightened-up code by J.E. McGimpsey
' Create the reference formula step by step, as needed
' If link is across workbooks ....
If Not myWorkbook Is myCell.Parent.Parent Then
PrefixString = _
"[" & myWorkbook.Name & "]"
'If link is across worksheets ....
If Not myWorksheet Is myCell.Parent Then PrefixString = _
"'" & PrefixString & myWorksheet.Name & "'!"
'Add the equal sign
PrefixString = "=" & PrefixString
With myRange
For i = 1 To .Columns.Count
For j = 1 To .Rows.Count
myCell(i, j).Formula = _
PrefixString & .Item(j, i).Address
Next j
Next i
End With
'Turn calc back to original
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
Exit Sub
ErrHandler:
MsgBox ErrString, vbOKOnly, PROJ_TITLE
End Sub
There is a more recent version of this macro wich you can
ask him to send you at:
[email protected]
Regards,
Felipe
