Sub CreateList()
Dim SourceSheet As Worksheet, VectorSheet As Worksheet
Dim ColumnRange As Range
Dim Prompt As String, Title As String, Default As String
Dim ReturnType As Integer
Dim i As Long
' Establish sheet containing data to convert
Set SourceSheet = ActiveSheet
' Check for pre-existing column vector sheets
i = 1
For Each ws In ThisWorkbook.Worksheets
If InStr(1, ws.Name, "Copy of " & SourceSheet.Name) <> 0 Then
i = i + 1
End If
Next ws
' Create a name for the worksheet to contain the column vector
If i > 1 Then
SheetName = "Copy of " & SourceSheet.Name & "(" & i & ")"
Else
SheetName = "Copy of " & SourceSheet.Name & "(" & i & ")"
End If
' Check name for appropriate length
If Len(SheetName) > 32 Then
SheetName = "Sheet" & ThisWorkbook.Worksheets.Count + 1
End If
' Get range to convert to column vector
Prompt = "Select the range you wish to convert to a column vector:"
Title = "Get Column Range"
Default = ActiveCell.CurrentRegion.Address
ReturnType = 8
On Error Resume Next
Set ColumnRange = Application.InputBox(Prompt, Title, Default, Type:=ReturnType)
On Error GoTo EH:
' Return "Invalid Range" if no range is selected
If ColumnRange Is Nothing Then
MsgBox "Error! Invalid range!"
Err.Clear
GoTo EH:
End If
' Return "Overflow Error" if too many cells are selected
If ColumnRange.Cells.Count > 65535 Then
MsgBox "Overflow error! No more than 65535 cells may be coverted at once!"
Err.Clear
GoTo EH:
End If
' End program if no data is contained in selection
If Application.WorksheetFunction.CountA(ColumnRange) = 0 Then
MsgBox "No data found!"
Err.Clear
GoTo EH:
End If
' Disable screen refresh to expedite execution
Application.ScreenUpdating = False
' Create new sheet to contain column vector
Set VectorSheet = Worksheets.Add
VectorSheet.Name = SheetName
' Create single column vector (if needed) and create ID list with AdvancedFilter
If ColumnRange.Columns.Count > 1 Then
Call CombineColumns(VectorSheet, ColumnRange)
Else
ColumnRange.Copy
With VectorSheet
.Activate
.Range("A1").PasteSpecial
.Range("A1").EntireRow.Insert shift:=xlShiftDown
.Range("A1").Value = "ID List"
End With
End If
Call FilterColumn(VectorSheet.Range("A1").EntireColumn)
EH:
With Err
If .Number <> 0 Then
MsgBox "Error!" & Chr(13) & Chr(13) & _
"Number: " & .Number & Chr(13) & _
"Description: " & .Description
End If
End With
Application.ScreenUpdating = True
Set VectorSheet = Nothing
Set SourceSheet = Nothing
Set ColumnRange = Nothing
End Sub
Sub CombineColumns(VectorSheet As Worksheet, ColumnRange As Range)
Dim MyArray As Variant
Dim StartCell As Range, EndCell As Range
' Dump data range into array to expedite processing
MyArray = ColumnRange
With VectorSheet
' Find first and last cell in the dataset
Set StartCell = .Cells(LBound(MyArray, 1), LBound(MyArray, 2))
Set EndCell = .Cells(UBound(MyArray, 1), UBound(MyArray, 2))
' Transpose data
' Application.WorksheetFunction.Transpose (MyArray)
' Dump array back into the worksheet
.Range(StartCell, EndCell) = MyArray
' Copy columns into first column to create single column vector
For i = 2 To UBound(MyArray, 2)
.Range(.Cells(LBound(MyArray, 1), i), .Cells(UBound(MyArray, 1), i)).Copy
StartCell.Offset(UBound(MyArray, 1) * (i - 1), 0).PasteSpecial
Next i
' Insert Header Row
.Range("A1").EntireRow.Insert shift:=xlShiftDown
.Range("A1").Value = "ID List"
End With
' Delete other columns
StartCell.Offset(0, 1).Resize(1, UBound(MyArray, 2)).EntireColumn.Delete
End Sub
Sub FilterColumn(MyColumn As Range)
MyColumn.AdvancedFilter xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
MyColumn.Delete
End Sub
