Option Explicit
Option Base 1
Sub BreakOutSiloData()
Dim NewBook As Workbook
Dim Book As Workbook
Dim SourceSheet As Worksheet
Dim Sheet As Worksheet
Dim Silos As Collection
Dim GroupIndex As Long
Dim SiloCount As Long
Dim SilosCreated As Long
Dim SiloIndex As Long
Dim ValueColumns As Long
Dim ValueRows As Long
Dim SiloKey As String
Dim Silo As Variant
Dim SourceData As Variant
Dim Headers As Variant
Dim Values As Variant
' Set these two objects as desired.
Set Book = ThisWorkbook
Set SourceSheet = Book.Worksheets("Sheet1")
Set NewBook = Workbooks.Add(xlWBATWorksheet)
On Error Resume Next
With SourceSheet
Headers = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
SourceData = .Range("A2", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, UBound(Headers, 2))).Value
End With
On Error GoTo 0
On Error GoTo ErrorExit
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
If IsEmpty(Headers) Or IsEmpty(SourceData) Then
MsgBox "We couldn't find the data.", vbExclamation + vbOKOnly
Exit Sub
End If
Set Silos = New Collection
For SiloIndex = LBound(SourceData, 1) To UBound(SourceData, 1)
SiloKey = CStr(SourceData(SiloIndex, 2))
If Not InCollection(Silos, SiloKey) Then
If Not IsEmpty(Values) Then Erase Values
Values = Application.Index(Application.Transpose(SourceData), , SiloIndex)
Silos.Add Values, SiloKey
Else
If Not IsEmpty(Values) Then Erase Values
Values = Silos.Item(SiloKey)
SiloCount = UBound(Values, 2) + 1
ValueRows = UBound(Values, 1)
ValueColumns = UBound(Values, 2) + 1
ReDim Preserve Values(1 To ValueRows, 1 To ValueColumns)
For GroupIndex = 1 To UBound(SourceData, 2)
Values(GroupIndex, ValueColumns) = SourceData(SiloIndex, GroupIndex)
Next GroupIndex
Silos.Remove SiloKey
Silos.Add Values, SiloKey
End If
Next SiloIndex
SilosCreated = 0
For Each Silo In Silos
On Error GoTo SkipSilo
SiloKey = Silo(2, 1)
NewBook.Worksheets.Add After:=NewBook.Worksheets(NewBook.Worksheets.Count)
Set Sheet = NewBook.Worksheets(NewBook.Worksheets.Count)
Sheet.Name = SiloKey
Sheet.Range("A1").Resize(1, UBound(Headers, 2)).Value = Headers
Sheet.Range("A2").Resize(UBound(Silo, 2), UBound(Silo, 1)).Value = Application.Transpose(Silo)
Sheet.Range("A2").Resize(UBound(Silo, 2), UBound(Silo, 1)).Sort Key1:=Sheet.Range("A2"), Order1:=xlAscending, Header:=xlNo
SilosCreated = SilosCreated + 1
SkipSilo:
Next Silo
NewBook.Worksheets(1).Delete
MsgBox "Data transfer complete. (" & SilosCreated & " of " & Silos.Count & ")", vbInformation + vbOKOnly
ResumeExit:
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
ErrorExit:
MsgBox "Something went wrong with the data transfer.", vbCritical + vbOKOnly
GoTo ResumeExit
End Sub
Public Function InCollection(ByVal CheckCollection As Collection, ByVal CheckKey As String) As Boolean
'
' Returns True if the specified key is found in the specified collection.
'
' Parameters: CheckCollection. Collection. Required. The collection to search in.
' CheckKey. String. Required. The string key to search in collection for.
'
On Error Resume Next
InCollection = CBool(Not IsEmpty(CheckCollection(CheckKey)))
On Error GoTo 0
End Function
