3 handy array-routines
Leo Heuser
wrapper<g>).
They all work on a range. All three automaticallly checks to see, if the destination range is empty.
You may wish to build a userform for each one to handle the various possibilities.
1. Transferring a n*m range to a n*1 or 1*m range.
2. Transferring a n*m range to a m*n range
3. Sorting a range showing the result by rows or by columns. The result is placed in the original range or elsewhere on the
sheet.
A happy Christmas to all of you
LeoH
'Transfers a n*m range into a single row/column
'If the range is surrounded by blanks, select a cell
'in the range, else select the range.
'Leo Heuser, december 1998
Sub ToSingleRowColumn()
Dim nArray() As Variant
Dim NumberOfRows As Long, NumberOfColumns As Long, i As Long
Dim rRow As Long, cColumn As Long, nNumber As Long, dummy, mMessage
Dim SingleColumn As Boolean
Dim DestCell As Range
Dim OriginalRegion As Range
Dim DestRegion As Range
' Set to False if transfer is to single row
SingleColumn = True
Set DestCell = Application.InputBox(prompt:="Enter destination cell", Type:=8)
rRow = DestCell.Row
cColumn = DestCell.Column
If Selection.Cells.Count = 1 Then
Set OriginalRegion = ActiveCell.CurrentRegion
Else
Set OriginalRegion = Selection
End If
NumberOfRows = OriginalRegion.Rows.Count
NumberOfColumns = OriginalRegion.Columns.Count
If SingleColumn = True Then
nNumber = NumberOfRows
Set DestRegion = DestCell.Resize(NumberOfRows * NumberOfColumns, 1)
Else
nNumber = NumberOfColumns
Set DestRegion = DestCell.Resize(1, NumberOfRows * NumberOfColumns)
End If
If Application.WorksheetFunction.CountA(DestRegion) <> 0 Then
dummy = "The destination range is not empty." & Chr(13) & "Overwrite destination range?"
mMessage = MsgBox(dummy, 308)
If mMessage = vbNo Then Exit Sub
End If
ReDim nArray(nNumber)
Application.ScreenUpdating = False
For i = 0 To nNumber - 1
If SingleColumn = True Then
OriginalRegion.Offset(i, 0).Resize(NumberOfRows - i, NumberOfColumns).Select
nArray(i) = Selection
Range(Cells(NumberOfColumns * i + rRow, cColumn), Cells(NumberOfColumns * i + rRow + NumberOfColumns - 1, cColumn)) =
Application.Transpose(nArray(i))
Else
OriginalRegion.Offset(0, i).Resize(NumberOfRows, NumberOfColumns - i).Select
nArray(i) = Selection
Range(Cells(rRow, NumberOfRows * i + cColumn), Cells(rRow, NumberOfRows * i + cColumn + NumberOfRows - 1)) =
Application.Transpose(nArray(i))
End If
Next i
' Set apostrophe in the next line,
' if you want to keep the original range
OriginalRegion.ClearContents
DestCell.Activate
Application.ScreenUpdating = True
End Sub
'Transposes a n*m range to a m*n range
'If the range is surrounded by blanks, select a cell
'in the range, else select the range.
'Leo Heuser, december 1998
Sub TransposeArray()
Dim nArray As Variant
Dim NumberOfRows As Long, NumberOfColumns As Long, dummy, mMessage
Dim DestCell As Range
Dim OriginalRegion As Range
Dim DestRegion As Range
Set DestCell = Application.InputBox(prompt:="Enter destination cell", Type:=8)
If Selection.Cells.Count = 1 Then
Set OriginalRegion = ActiveCell.CurrentRegion
Else
Set OriginalRegion = Selection
End If
NumberOfRows = OriginalRegion.Rows.Count
NumberOfColumns = OriginalRegion.Columns.Count
Set DestRegion = DestCell.Resize(NumberOfColumns, NumberOfRows)
If Application.WorksheetFunction.CountA(DestRegion) <> 0 Then
dummy = "The destination range is not empty." & Chr(13) & "Overwrite destination range?"
mMessage = MsgBox(dummy, 308)
If mMessage = vbNo Then Exit Sub
End If
nArray = OriginalRegion
Application.ScreenUpdating = False
DestRegion = Application.Transpose(nArray)
' Set apostrophe in the next line,
' if you want to keep the original range
OriginalRegion.ClearContents
Application.ScreenUpdating = True
End Sub
'Sorts a range
'If the range is surrounded by blanks, select a cell
'in the range, else select the range.
'You have a choice of overwriting the original range
'(If you have formulas in there, they wil be overwritten!!)
'or placing the sorted range somewhere else on the sheet.
'Leo Heuser, december 1998
Sub SortRange()
Dim nArray() As Variant
Dim NumberOfRows As Long, NumberOfColumns As Long, i As Long
Dim rRow As Long, cColumn As Long, nNumber As Long, dummy, mMessage
Dim ByRow As Boolean, SortAscending As Boolean
Dim BufferCell As Range, DestCell As Range
Dim OriginalRegion As Range
Dim BufferRegion As Range
Dim DestRegion As Range
'Set to False if result is to be shown by columns
ByRow = True
'Set to False for sort to be descending
SortAscending = True
'The last column in the sheet is used as a buffer
Set BufferCell = Range("IV1")
rRow = BufferCell.Row
cColumn = BufferCell.Column
If Selection.Cells.Count = 1 Then
Set OriginalRegion = ActiveCell.CurrentRegion
Else
Set OriginalRegion = Selection
End If
NumberOfRows = OriginalRegion.Rows.Count
NumberOfColumns = OriginalRegion.Columns.Count
Set BufferRegion = BufferCell.Resize(NumberOfRows * NumberOfColumns, 1)
If ByRow = True Then
nNumber = NumberOfRows
Else
nNumber = NumberOfColumns
End If
If Application.WorksheetFunction.CountA(BufferRegion) <> 0 Then
dummy = "The buffer range is not empty." & Chr(13) & "Overwrite buffer range?"
mMessage = MsgBox(dummy, 308)
If mMessage = vbNo Then Exit Sub
End If
Set DestCell = Application.InputBox(prompt:="Enter destination cell", Default:=OriginalRegion(1, 1).Address, Type:=8)
Set DestRegion = DestCell.Resize(NumberOfRows * NumberOfColumns, 1)
If DestCell.Address <> OriginalRegion(1, 1).Address Then
If Application.WorksheetFunction.CountA(DestRegion) <> 0 Then
dummy = "The destination range is not empty." & Chr(13) & "Overwrite destination range?"
mMessage = MsgBox(dummy, 308)
If mMessage = vbNo Then Exit Sub
End If
Else
mMessage = MsgBox("Overwrite original range?", 308)
If mMessage = vbNo Then Exit Sub
End If
ReDim nArray(NumberOfRows)
Application.ScreenUpdating = False
For i = 0 To NumberOfRows - 1
OriginalRegion.Offset(i, 0).Resize(NumberOfRows - i, NumberOfColumns).Select
nArray(i) = Selection
Range(Cells(NumberOfColumns * i + rRow, cColumn), Cells(NumberOfColumns * i + rRow + NumberOfColumns - 1, cColumn)) =
Application.Transpose(nArray(i))
Next i
If SortAscending = True Then
BufferRegion.Sort key1:=BufferRegion(1, 1), order1:=xlAscending
Else
BufferRegion.Sort key1:=BufferRegion(1, 1), order1:=xlDescending
End If
For i = 0 To nNumber - 1
If ByRow = True Then
DestRegion.Offset(i, 0).Resize(NumberOfRows - i, NumberOfColumns) =
Application.Transpose(BufferRegion.Offset(NumberOfColumns * i, 0).Resize(NumberOfColumns, 1))
Else
DestRegion.Offset(0, i).Resize(NumberOfRows, NumberOfColumns - i) =
Application.Transpose(Application.Transpose(BufferRegion.Offset(NumberOfRows * i, 0).Resize(NumberOfRows, 1)))
End If
Next i
BufferRegion.ClearContents
DestRegion(1, 1).Activate
Application.ScreenUpdating = True
End Sub
Patrick Molloy
Happy Xmas & New Year to you too
____________________________________________________________________________
_____
Leo Heuser wrote in message ...
Laurent Longre
Tak, og Glædelig Jul !
Med venlig hilsen,
Laurent
Leo Heuser a écrit:
>
> Here are three array routines in a christmas-wrapper, which you may find useful from time to time (the routines not the
> wrapper<g>).
> <snip>