I gave it another approach aside from SQL and sorts (already provided before).
I tested this code and it works.
The general idea behind this code:
- Class module "clsSheet" contains all information per sheet, ie. column headers A, B, C, but also the used range, the array in which this range is loaded and the maximum row / col.
- These self created data objects are loaded into a collection, after which the next part of the code will execute all code in memory (fast).
- A dictionary is created and will contain the "module name" (ie. module1,2,3 etc...) as key, and a clsModule object as value. When a key (thus module name) does not exist yet, a new item will be added.
- The clsModule class keeps the information on each modulename, ie. columns A, B and C information. The information is stored in the form of arrays.
- When all information is stored in the dictionary, it is only a matter of translating the dictionary content back to a form that is preferred. In this case, I chose to give to each sheet the name of dictionary keys and load the data to their corresponding sheets.
This code includes:
- Dynamically finds headers with names "A", "B" and "C", which reduces risk for bugs;
- Fast execution;
- Creates a new workbook and writes the values for each "module" to a different sheet.
- These classes are re-usable in other situations with minimum modification needed.
The major benefit of this approach is flexibility. Since you load all data in a framework, you can virtually perform any actions afterwards by setting the classes and calling their properties.
Sub GetModules()
Dim cSheet As clsSheet
Dim cModule As clsModule
Dim oSheet As Excel.Worksheet
Dim oColl_Sheets As Collection
Dim oDict As Object
Dim vTemp_Array_A As Variant
Dim vTemp_Array_B As Variant
Dim vTemp_Array_C As Variant
Dim lCol_A As Long
Dim lCol_B As Long
Dim lCol_C As Long
Dim lMax_Row As Long
Dim lMax_Col As Long
Dim oRange As Range
Dim oRange_A As Range
Dim oRange_B As Range
Dim oRange_C As Range
Dim vArray As Variant
Dim lCnt As Long
Dim lCnt_Modules As Long
Dim oBook As Excel.Workbook
Dim oSheet_Results As Excel.Worksheet
Set oColl_Sheets = New Collection
Set oDict = CreateObject("Scripting.Dictionary")
'Get number of columns, rows and headers A, B, C dynamically
'This is useful in case columns are inserted
For Each oSheet In ThisWorkbook.Sheets
Set cSheet = New clsSheet
Set cSheet = cSheet.get_Sheet_Data(cSheet, oSheet)
oColl_Sheets.Add cSheet
Next oSheet
'At this point, your entire sheet data structure is already contained in the collection oColl_Sheets
Set cSheet = Nothing
'Loop through the sheet objects and retrieve the values into modules
For Each cSheet In oColl_Sheets
'Now you load back all data from the sheet and perform loops in memory through the arrays
lCol_A = cSheet.fA_Col
lCol_B = cSheet.fB_Col
lCol_C = cSheet.fC_Col
lMax_Row = cSheet.fMax_Row
lMax_Col = cSheet.fMax_Col
Set oRange = cSheet.fRange
vArray = cSheet.fArray
For lCnt = 1 To lMax_Row - 1
'Check if the module already exists
If Not oDict.Exists(vArray(1 + lCnt, 1)) Then '+1 due to header
lCnt_Modules = lCnt_Modules + 1
Set cModule = New clsModule
'Add to dictionary when new module (thus key) is new
Set cModule = cModule.Add_To_Array_A(cModule, lCol_A, vArray(1 + lCnt, lCol_A), True)
Set cModule = cModule.Add_To_Array_B(cModule, lCol_B, vArray(1 + lCnt, lCol_B), True)
Set cModule = cModule.Add_To_Array_C(cModule, lCol_C, vArray(1 + lCnt, lCol_C), True)
oDict.Add vArray(1 + lCnt, 1), cModule
Else
Set cModule = oDict(vArray(1 + lCnt, 1))
'Replace when module (thus key) already exists
Set cModule = cModule.Add_To_Array_A(cModule, lCol_A, vArray(1 + lCnt, lCol_A), False)
Set cModule = cModule.Add_To_Array_B(cModule, lCol_A, vArray(1 + lCnt, lCol_B), False)
Set cModule = cModule.Add_To_Array_C(cModule, lCol_A, vArray(1 + lCnt, lCol_C), False)
Set oDict(vArray(1 + lCnt, 1)) = cModule
End If
Next lCnt
Next cSheet
'Now you have all the data available in your dictionary: per module (key), there is an array with the data you need.
'The only thing you have to do is open a new workbook and paste the data there.
'Below an example how you can paste the results per worksheet
Set oBook = Workbooks.Add
Set oSheet_Results = oBook.Sheets(1)
lCnt = 0
For lCnt = 0 To oDict.Count - 1
'Fill in values from dictionary
oBook.Sheets.Add().Name = oDict.Keys()(lCnt)
ReDim vTemp_Array_A(1 To UBound(oDict.Items()(lCnt).fA_Arr))
ReDim vTemp_Array_B(1 To UBound(oDict.Items()(lCnt).fB_Arr))
ReDim vTemp_Array_C(1 To UBound(oDict.Items()(lCnt).fC_Arr))
oBook.Sheets(oDict.Keys()(lCnt)).Range("A1").Value = "A"
oBook.Sheets(oDict.Keys()(lCnt)).Range("B1").Value = "B"
oBook.Sheets(oDict.Keys()(lCnt)).Range("C1").Value = "C"
vTemp_Array_A = oDict.Items()(lCnt).fA_Arr
vTemp_Array_B = oDict.Items()(lCnt).fB_Arr
vTemp_Array_C = oDict.Items()(lCnt).fC_Arr
Set oRange_A = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 1), Cells(1 + UBound(vTemp_Array_A), 1))
Set oRange_B = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 2), Cells(1 + UBound(vTemp_Array_B), 2))
Set oRange_C = oBook.Sheets(oDict.Keys()(lCnt)).Range(Cells(2, 3), Cells(1 + UBound(vTemp_Array_C), 3))
oRange_A = Application.Transpose(vTemp_Array_A)
oRange_B = Application.Transpose(vTemp_Array_B)
oRange_C = Application.Transpose(vTemp_Array_C)
Next lCnt
Set oColl_Sheets = Nothing
Set oRange = Nothing
Set oDict = Nothing
End Sub
Class module called "clsModule"
Option Explicit
Private pModule_Nr As Long
Private pA_Arr As Variant
Private pB_Arr As Variant
Private pC_Arr As Variant
Public Function Add_To_Array_A(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule
Dim vArray As Variant
vArray = cModule.fA_Arr
If bNew Then
ReDim vArray(1 To 1)
vArray(1) = vValue
Else
ReDim Preserve vArray(1 To UBound(vArray) + 1)
vArray(UBound(vArray)) = vValue
End If
cModule.fA_Arr = vArray
Set Add_To_Array_A = cModule
End Function
Public Function Add_To_Array_B(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule
Dim vArray As Variant
vArray = cModule.fB_Arr
If bNew Then
ReDim vArray(1 To 1)
vArray(1) = vValue
Else
ReDim Preserve vArray(1 To UBound(vArray) + 1)
vArray(UBound(vArray)) = vValue
End If
cModule.fB_Arr = vArray
Set Add_To_Array_B = cModule
End Function
Public Function Add_To_Array_C(cModule As clsModule, lCol As Long, vValue As Variant, bNew As Boolean) As clsModule
Dim vArray As Variant
vArray = cModule.fC_Arr
If bNew Then
ReDim vArray(1 To 1)
vArray(1) = vValue
Else
ReDim Preserve vArray(1 To UBound(vArray) + 1)
vArray(UBound(vArray)) = vValue
End If
cModule.fC_Arr = vArray
Set Add_To_Array_C = cModule
End Function
Property Get fModule_Nr() As Long
fModule_Nr = pModule_Nr
End Property
Property Let fModule_Nr(lModule_Nr As Long)
pModule_Nr = lModule_Nr
End Property
Property Get fA_Arr() As Variant
fA_Arr = pA_Arr
End Property
Property Let fA_Arr(vA_Arr As Variant)
pA_Arr = vA_Arr
End Property
Property Get fB_Arr() As Variant
fB_Arr = pB_Arr
End Property
Property Let fB_Arr(vB_Arr As Variant)
pB_Arr = vB_Arr
End Property
Property Get fC_Arr() As Variant
fC_Arr = pC_Arr
End Property
Property Let fC_Arr(vC_Arr As Variant)
pC_Arr = vC_Arr
End Property
Class module called "clsSheet"
Option Explicit
Private pMax_Col As Long
Private pMax_Row As Long
Private pArray As Variant
Private pRange As Range
Private pA_Col As Long
Private pB_Col As Long
Private pC_Col As Long
Public Function get_Sheet_Data(cSheet As clsSheet, oSheet As Excel.Worksheet) As clsSheet
Dim oUsed_Range As Range
Dim lLast_Col As Long
Dim lLast_Row As Long
Dim iCnt As Integer
Dim vArray As Variant
Dim lNr_Rows As Long
Dim lNr_Cols As Long
Dim lCnt As Long
With oSheet
lLast_Row = .Cells(.Rows.Count, "A").End(xlUp).Row
lLast_Col = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
oSheet.Activate
Set oUsed_Range = oSheet.Range(Cells(1, 1), Cells(lLast_Row, lLast_Col))
cSheet.fRange = oUsed_Range
lNr_Rows = oUsed_Range.Rows.Count
cSheet.fMax_Row = lNr_Rows
lNr_Cols = oUsed_Range.Columns.Count
cSheet.fMax_Col = lNr_Cols
ReDim vArray(1 To lNr_Rows, 1 To lNr_Cols)
vArray = oUsed_Range
cSheet.fArray = vArray
For lCnt = 1 To lNr_Cols
Select Case vArray(1, lCnt)
Case "A"
cSheet.fA_Col = lCnt
Case "B"
cSheet.fB_Col = lCnt
Case "C"
cSheet.fC_Col = lCnt
End Select
Next lCnt
Set get_Sheet_Data = cSheet
End Function
Property Get fMax_Col() As Long
fMax_Col = pMax_Col
End Property
Property Let fMax_Col(lMax_Col As Long)
pMax_Col = lMax_Col
End Property
Property Get fMax_Row() As Long
fMax_Row = pMax_Row
End Property
Property Let fMax_Row(lMax_Row As Long)
pMax_Row = lMax_Row
End Property
Property Get fRange() As Range
Set fRange = pRange
End Property
Property Let fRange(oRange As Range)
Set pRange = oRange
End Property
Property Get fArray() As Variant
fArray = pArray
End Property
Property Let fArray(vArray As Variant)
pArray = vArray
End Property
Property Get fA_Col() As Long
fA_Col = pA_Col
End Property
Property Let fA_Col(lA_Col As Long)
pA_Col = lA_Col
End Property
Property Get fB_Col() As Long
fB_Col = pB_Col
End Property
Property Let fB_Col(lB_Col As Long)
pB_Col = lB_Col
End Property
Property Get fC_Col() As Long
fC_Col = pC_Col
End Property
Property Let fC_Col(lC_Col As Long)
pC_Col = lC_Col
End Property
