0

I am trying to create a handy tool wherein I create a list of all possible permutations available with many lists, and cut any permutations that do not fit conditional rules. There are MANY lists and values within those lists, so there are millions of lines in the original array before the conditionals. For the permutations table, I used an adored favorite of Ejaz Ahmed, http://strugglingtoexcel.wordpress.com/ - 'MixMatchColumns'. This works GREAT for small list sets, but I'm taking it to the max. I read comments and it sounds like I may want to use a relational database instead (but I've never created one and feel like it may be possible in Excel) or I can use a split function. I will copy/paste my VBA below, but it is atrocious (I'm really new but highly motivated to learn... and very patient). I've seen a lot of collecting data from many worksheets into an array, but not to do the opposite.

  1. ResultArray () is the initial array with lngNumberRows (# of rows) and lngCol (# of columns). There is a header row in Row 1. Let's say there are 2,000,0000 (2M) rows of data in ResultArray.
  2. Only 500,000 rows should exist on each Sheet2, Sheet3, Sheet4, SheetX until all rows from ResultArray are printed.
  3. There will be a set of If/Then statements to 'trim the fat' and cut out rows that don't meet criteria (e.g., if value in cell "A2" = "Z" and value in cell "C" & lngNumberRows is "4", then delete the row. I'm pretty set on this part of the VBA but was learning about an auto filter option that would likely speed this up. There are maybe ~65 conditional rules that each row will have to pass. Eek! but again, I'm patient and motivated.
  4. Nice-to-have: At the end, I'd like to have all the rows compiled onto as few sheets as possible.

MixMatchColumns http://strugglingtoexcel.wordpress.com/

Option Explicit 'Always a good idea to have this

'======================================================================
'MixMatchColumns
'======================================================================
'Macro that accepts a Data Range. Treats each of the columns as a
'set and generates a list of all permutations of the elements in
'each of the lists.
'Arguments:
'DataRange          - Range that contains the elements in each list
'ResultRange        - Cell where the results will be pasted
'DataHasHeaders     - Boolean variable that is used to specify if the
'                     data range included the column headers.
'                     Comes in handy if the CurrentRegion property
'                     is used to select the datarange
'HeadersInResult    - Boolean variable to decide if the uset wants
'                      to paste the headers also along with the results
'======================================================================
'Author     :   Ejaz Ahmed
'Date       :   21 February 2014
'Website    :   http://strugglingtoexcel.wordpress.com/
'Email      :   StrugglingToExcel@outlook.com
'======================================================================
Sub MixMatchColumns(ByRef DataRange As Range, _
                    ByRef ResultRange As Range, _
                    Optional ByVal DataHasHeaders As Boolean = False, _
                    Optional ByVal HeadersInResult As Boolean = False)

Dim rngData As Range
Dim rngResults As Range
Dim lngCount As Long
Dim lngCol As Long
Dim lngNumberRows As Long
Dim ItemCount() As Long
Dim RepeatCount() As Long
Dim PatternCount() As Long
'Long Variables for the Variour For Loops
Dim lngForRow As Long
Dim lngForPattern As Long
Dim lngForItem As Long
Dim lngForRept As Long
'Temporary Arrays used to store the Data and Results
Dim DataArray() As Variant
Dim ResultArray() As Variant

'If the Data range has headers, adjust the
'Range to contain only data
Set rngData = DataRange
If DataHasHeaders Then
    Set rngData = rngData.Offset(1).Resize(rngData.Rows.Count - 1)
End If

'Initialize the Data Array
DataArray = rngData.Value
'Get the number of Columns
lngCol = rngData.Columns.Count

'Initialize the Arrays
ReDim ItemCount(1 To lngCol)
ReDim RepeatCount(1 To lngCol)
ReDim PatternCount(1 To lngCol)

'Get the number of items in each column
For lngCount = 1 To lngCol
    ItemCount(lngCount) = _
        Application.WorksheetFunction.CountA(rngData.Columns(lngCount))
    If ItemCount(lngCount) = 0 Then
        MsgBox "Column " & lngCount & " does not have any items in it."
        Exit Sub
    End If
Next

'Calculate the number of Permutations
lngNumberRows = Application.Product(ItemCount)


        
    

'Initialize the Results array
ReDim ResultArray(1 To lngNumberRows, 1 To lngCol)

'Get the number of times each of the items repeate
RepeatCount(lngCol) = 1
For lngCount = (lngCol - 1) To 1 Step -1
    RepeatCount(lngCount) = ItemCount(lngCount + 1) * _
                                RepeatCount(lngCount + 1)
Next lngCount

'Get howmany times the pattern repeats
For lngCount = 1 To lngCol
    PatternCount(lngCount) = lngNumberRows / _
            (ItemCount(lngCount) * RepeatCount(lngCount))
Next

'The Loop begins here, Goes through each column
For lngCount = 1 To lngCol
'Reset the row number for each column iteration
lngForRow = 1
    'Start the Pattern
    For lngForPattern = 1 To PatternCount(lngCount)
        'Loop through each item
        For lngForItem = 1 To ItemCount(lngCount)
            'Repeate the item
            For lngForRept = 1 To RepeatCount(lngCount)
                'Store the value in the array
                ResultArray(lngForRow, lngCount) = _
                        DataArray(lngForItem, lngCount)
                'Increment the Row number
                lngForRow = lngForRow + 1
            Next lngForRept
        Next lngForItem
    Next lngForPattern
Next lngCount

'Output the results
Set rngResults = ResultRange(1, 1).Resize(lngNumberRows, lngCol)
'If the user wants headers in the results
If DataHasHeaders And HeadersInResult Then
    rngResults.Rows(1).Value = DataRange.Rows(1).Value
    Set rngResults = rngResults.Offset(1)
End If
rngResults.Value = ResultArray()

    'Dim lngTabs As Long
    'Dim lngRemainingRows As Long
    
    
'THIS IS WHAT IS ALL JUNK / MY OWN....    
    'lngTabs = lngNumberRows / (1000000 - 1)
    'Dim lngTabCounter As Long
    'If lngNumberRows > 500000 Then
        'lngTabs = Round((lngNumberRows / 500000), 0)
        'Range("O1") = lngNumberRows
        'Range("O2") = lngCol
        
        
        
        'Dim I As Integer
        'Dim SplitIdx As Integer
        
        'For I = 1 To lngNumberRows
            'If lngNumberRows > 10 Then
                'SplitIdx = I - 1
                'Exit For
            'End If
        'Next I
        
        'If SplitIdx = 0 Or SplitIdx = 10 Then
        
        'End If
        
        'Range("O3") = SplitIdx
        
        
        'NewGirl:  Try Again!
        
              'Dim IC As Long
              'IC = lngNumberRows / 2 ' Items Count in first array ar1
              'Range("O3") = IC
              'Dim ar2() As Variant
              'Dim ar3() As Variant
              
              'Dim I As Integer
              'ResultArray
            
              'ReDim ar2(IC - 1)
              'ReDim ar3(UBound(ResultArray) - IC)
            
              'For I = 0 To IC - 1
               'ar2(I) = ResultArray(I)
              'Next
            
              'For I = 0 To UBound(ResultArray) - IC
               'ar3(I) = ResultArray(I + IC - 1)
              'Next
            
            'Test:
              'Debug.Print "ar2:"
              'For I = LBound(ar2) To UBound(ar2)
               'Debug.Print ar2(I)
              'Next
            
              'Debug.Print "======" & Chr(13) & "ar3:"
            
              'For I = LBound(ar3) To UBound(ar3)
               'Debug.Print ar3(I)
              'Next
        
        'rngResults.Value = ResultArray()
        'For I = LBound(ar2) To UBound(ar2)
            'Range("N12").Value = ar2(I)
            'Next
            
        'For I = LBound(ar3) To UBound(ar3)
            'Range("S12").Value = ar3(I)
            'Next
        
  'END JUNK AND RETURN TO REAL CODE  

End Sub


Sub CoverMacro()

Dim rngData As Range
Dim rngResults As Range
Dim booDataHeader As Boolean
Dim booResultHeader As Boolean
Dim lngAns As Long
Dim strMessage As String
Dim strTitle As String

strTitle = "Mix 'n Match"

strMessage = "Select the Range that has the Lists:" _
    & vbNewLine & "Make sure there are no blank cells in between."

On Error Resume Next
Set rngData = Application.InputBox(strMessage, strTitle, , , , , , 8)
If Not Err.Number = 0 Then
    Err.Clear
    On Error GoTo 0
    Exit Sub
End If
    

strMessage = "Does the Data have headers in it?"
lngAns = MsgBox(strMessage, vbYesNo, strTitle)
If Not Err.Number = 0 Then
    Err.Clear
    On Error GoTo 0
    Exit Sub
End If

If lngAns = vbYes Then
    booDataHeader = True
Else
    booDataHeader = False
End If

strMessage = "Select the cell where you'd like the results to be pasted"
Set rngResults = Application.InputBox(strMessage, strTitle, , , , , , 8)
If Not Err.Number = 0 Then
    Err.Clear
    On Error GoTo 0
    Exit Sub
End If

If booDataHeader Then
    strMessage = "Do you want headers in your Result?"
    lngAns = MsgBox(strMessage, vbYesNo, strTitle)
    
    If Not Err.Number = 0 Then
        Err.Clear
        On Error GoTo 0
        Exit Sub
    End If

    If lngAns = vbYes Then
        booResultHeader = True
    Else
        booResultHeader = False
    End If
Else
    booResultHeader = False
End If

Call MixMatchColumns(rngData, rngResults, booDataHeader, booResultHeader)
End Sub
braX
  • 11,506
  • 5
  • 20
  • 33
  • Do you have a data sample and a desired outcome example? I like your enthusiasm by the way. – Evil Blue Monkey Jun 22 '22 at 07:39
  • It would be easier to manage the processing of your data if you make `MixMatchColumns` a function which just returns your array of results, then create a "filter" function which takes the array and filters out the unwanted rows. Then finally a sub which populates the filtered array to the sheet(s). Similar Q on combinations: https://stackoverflow.com/questions/19780016/vba-write-all-possible-combinations-of-4-columns-of-data/19780307#19780307 FYI your wordpress link leads to "This site is currently private" – Tim Williams Jun 22 '22 at 16:10

0 Answers0