Sign Up

Have an account? Sign In Now

Sign In

Forgot Password?

Don't have account, Sign Up Here

Forgot Password

Lost your password? Please enter your email address. You will receive a link and will create a new password via email.

Have an account? Sign In Now

You must login to ask question.

Forgot Password?

Need An Account, Sign Up Here

Please briefly explain why you feel this question should be reported.

Please briefly explain why you feel this answer should be reported.

Sign InSign Up

Softans

Softans Logo Softans Logo
Search
Ask A Question

Mobile menu

Close
Ask a Question
  • Home
  • Add group
  • Groups page
  • Communities
  • Questions
    • New Questions
    • Trending Questions
    • Must read Questions
    • Hot Questions
  • Polls
  • Tags
  • Badges
  • Users
  • Help
Home/ Questions/Q 3914
In Process
Franklin
Franklin
Asked: November 25, 20222022-11-25T09:35:30+00:00 2022-11-25T09:35:30+00:00

VBA Permutate 1D array adding set value to each array item n number of times

I am trying to figure out a loop logic to get all possible permutations where I add a set value to each item in a set array iLoop number of times. I’m gonna try my best to explain what I am looking for.

I have a set value “StrokeValue” and a set array “DistanceMatesArray”

Dim StrokeValue as single
Dim DistanceMatesArray as variant

StrokeValue = 300
DistanceMatesArray = Array(300, 300, 300, 300)

Now I need to loop through each possible result where I add StrokeValue to each Item which in the first loop would result in possible DistanceMatesArrays:

enter image description here

The tricky part is when I want to add StrokeValue more than once and get every outcome where I added StrokeValue iLoop number of time “AllowedActions” resulting in a list such as:

enter image description here

I kind of suspect that I need a 2D array to store all the results from previous loop., that’s why in the example the rows are coloured to indicate which one row was taken as a starting point to add the StrokeValue once

What I got so far looks like this:

Public StrokeValue As Single
Public DistanceMatesArray As Variant
Public iError As Long
Public NumberOfCombinations As Long
Public x As Long
Public y As Long
Public i As Long

Option Explicit

Sub Test()

'Declare variables
Dim PreviousLoopResultsArray As Variant
Dim NextLoopResultsArray As Variant
Dim iresults As Long
Dim iLoop As Long
Dim iPreviousResult As Long

'Set variables
StrokeValue = 300

'Array
DistanceMatesArray = Array(300, 300, 300, 300)
ReDim NextLoopResultsArray(0, UBound(DistanceMatesArray))

For i = LBound(DistanceMatesArray) To UBound(DistanceMatesArray)
    NextLoopResultsArray(0, i) = DistanceMatesArray(i)
Next i
'------------------------------------------------------
'Loop
Do While iError = NumberOfCombinations
    
    'Try DistanceMatesArray
        For i = 0 To iresults
            For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
                DistanceMatesArray(x) = NextLoopResultsArray(i, x)
            Next x
            Debug.Print Join(DistanceMatesArray)
            'TRY HERE
        Next i
    
    'Array
    PreviousLoopResultsArray = NextLoopResultsArray
    
    'Array
    If iLoop <> 0 Then
        For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
            DistanceMatesArray(x) = PreviousLoopResultsArray(iPreviousResult, x)
        Next x
    End If
    
    'Set variables
    iLoop = iLoop + 1
    iPreviousResult = 1
    iresults = ((UBound(DistanceMatesArray) + 1) ^ iLoop) - 1
    ReDim NextLoopResultsArray(iresults, UBound(DistanceMatesArray))
    
    'Populate NextLoopResultsArray
    For y = 0 To iresults 'Loop vertically
        
        If y Mod (UBound(DistanceMatesArray) + 1) = 0 And y <> iresults And y <> 0 Then
            For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
                DistanceMatesArray(x) = PreviousLoopResultsArray(iPreviousResult, x)
            Next x
            iPreviousResult = iPreviousResult + 1
        End If
        
        For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
            NextLoopResultsArray(y, x) = DistanceMatesArray(x)
            With ThisWorkbook.Worksheets(1).Cells(y + 1, x + 1)
                .Value = NextLoopResultsArray(y, x)
            End With
        Next x
    Next y
    
    'Modify NextLoopResultsArray
    x = 0
    For y = 0 To iresults 'Loop vertically
        NextLoopResultsArray(y, x) = NextLoopResultsArray(y, x) + StrokeValue
        With ThisWorkbook.Worksheets(1).Cells(y + 1, x + 1)
            .Value = NextLoopResultsArray(y, x)
            .Interior.Color = vbYellow
        End With
                
        If x + 1 > UBound(DistanceMatesArray) Then
            x = 0
        Else
            x = x + 1
        End If
    Next y
    
    'Set variables
    iPreviousResult = 0
    
    'Excel reset
    For i = 1 To (UBound(DistanceMatesArray) + 1)
        Columns(i).Clear
    Next i
Loop

End Sub

At the end of the loop I am expecting to have each one row as DistanceMatesArray i.e. one of them would now be

DistanceMatesArray  = array(300,600,600,300)

Where it added StrokeValue twice.

Would someone, please, help me figure out a shorter and simpler logic behind this?

EDIT:

Results expected after running it up to 3 loops looks like this: enter image description here

And without duplicate outcomes

enter image description here

Continuing to try and figure out the logic of it, maybe now someone get’s a betetr idea for what I am lookign for and can help

No need to mention that it’s an infinite loop – I know that and That’s the point, it needs to go on untill I validate the right array in which case iError <> NumberOfCombinations.

  • 0
  • 1 1 Answer
  • 14 Views
  • 0 Followers
  • 0
Answer
Share
  • Facebook
  • Report

1 Answer

  • Voted
  • Oldest
  • Recent
  1. Ghulam Nabi
    2022-11-25T09:36:34+00:00Added an answer on November 25, 2022 at 9:36 am

    Been able to learn more about arrays, so I consider this a big win. The code took in account the duplicates but for now your iterations are hardset (could easily ask how many iterations with an inputbox), not in the endless loop you had set up, hope that rework won’t be too much. Some variables are reworked, I tried to keep most of your original ones though.

    Public StrokeValue As Single
    Public DistanceMatesArray As Variant
    Public iError As Long
    Public iTerations As Long
    Public i As Long
    Public j As Long
    Public k As Long
    
    Option Explicit
    
    Sub TestArrayfill()
    
        Dim pArray As Variant, nArray As Variant, cArray As Variant
        Dim iresults As Long, iLoop As Long, nb As Long, actB As Long, addCounter As Long, Lastrow As Long
        
        'Set variables
        StrokeValue = 300
        addCounter = 1
        iTerations = 4
        
        'Array
        DistanceMatesArray = Array(300, 300, 300, 300)
        nb = UBound(DistanceMatesArray) + 1
        ReDim Preserve DistanceMatesArray(1 To nb)
        cArray = DistanceMatesArray
        ReDim pArray(1 To nb, 1 To nb)
        
        For i = 1 To nb
            pArray(1, i) = DistanceMatesArray(i)
        Next i
        actB = nb
        
        For iLoop = 1 To iTerations 'I can't figure out the limitations with permutations so we'll just bruteforce it with nb*actB (maximum possibilities)
            ReDim nArray(1 To nb * actB, 1 To nb) '(re)setting nArray
            If iLoop = 1 Then actB = 1 'workaround to have pArray as a 2D-array
            For i = 1 To actB 'loop through every row in pArray except for when iLoop = 1
                For j = 1 To nb 'loop through every cell in pArray(i)
                    For k = 1 To nb 'setting the extra StrokeValue
                        If j = k Then
                            cArray(k) = pArray(i, k) + StrokeValue
                        Else
                            cArray(k) = pArray(i, k)
                        End If
                    Next k
                    If Not arrElemInArray(cArray, nArray) Then
                        For k = 1 To nb
                            nArray(addCounter, k) = cArray(k) 'add the "row" to our nArray
                        Next k
                        addCounter = addCounter + 1
                    End If
                Next j
            Next i
            actB = addCounter - 1
            nArray = Application.Transpose(nArray) 'transpose first because you can only ReDim Preserve on the outer dimensions
            ReDim Preserve nArray(1 To nb, 1 To actB) 'only keep the rows used by keeping the duplicates out
            nArray = Application.Transpose(nArray) 'transpose back to our original array configuration
            pArray = Application.Transpose(pArray)
            ReDim pArray(1 To UBound(nArray, 2), UBound(nArray, 1))
            pArray = Application.Transpose(pArray)
            pArray = nArray
            addCounter = 1
            Lastrow = Range("A" & Rows.Count).End(xlUp).Row
            If Lastrow = 1 Then
                Cells(Lastrow, 1).Value = "Loop" & iLoop
            Else
                Cells(Lastrow + 1, 1).Value = "Loop " & iLoop
                Lastrow = Lastrow + 1
            End If
            Cells(Lastrow + 1, 1).Resize(UBound(nArray, 1), UBound(nArray, 2)) = nArray
        Next iLoop
        
    End Sub
    
    Function arrElemInArray(arr As Variant, arrX As Variant) As Boolean 'this is from one of your previous questions btw, just a bit modified to fit our needs
       Dim i As Long, j As Long, boolFound As Boolean, mtch
    
       If Not IsArray(arrX) Then
             For j = LBound(arr) To UBound(arr)
                If arr(j) = arrX Then arrElemInArray = True: Exit For
            Next j
            Exit Function
       End If
       For i = LBound(arrX) To UBound(arrX)
            boolFound = True 'True at beginning so if any cells deviates from the corresponding check, it gets set to False, ergo it doesn't exist yet.
            For j = LBound(arr) To UBound(arr)
                If arr(j) <> arrX(i, j) Then
                    boolFound = False
                End If
            Next j
            If boolFound Then arrElemInArray = True: Exit Function
       Next i
       arrElemInArray = False
    End Function
    

    Hope it’s all clear and works for you 🙂

    • 0
    • Reply
    • Share
      Share
      • Share on Facebook
      • Share on Twitter
      • Share on LinkedIn
      • Share on WhatsApp
      • Report

Leave an answer
Cancel reply

You must login to add an answer.

Forgot Password?

Need An Account, Sign Up Here

Sidebar

Ask A Question
  • Popular
  • Answers
  • Ghulam Nabi

    Why are the British confused about us calling bread rolls ...

    • 5 Answers
  • Ghulam Nabi

    Is this statement, “i see him last night” can be ...

    • 4 Answers
  • Alex

    application has failed to start because no appropriate graphics hardware ...

    • 4 Answers
  • Ghulam Nabi
    Ghulam Nabi added an answer Improving the launch time of your Flutter Firebase app involves… May 25, 2023 at 12:08 pm
  • Ghulam Nabi
    Ghulam Nabi added an answer Currently, as of my knowledge cutoff in September 2021, the… May 25, 2023 at 12:05 pm
  • Ghulam Nabi
    Ghulam Nabi added an answer When using a GitHub Application token for authentication in your… May 25, 2023 at 12:03 pm

Trending Tags

c++ cypress flutter git java javascript python selenium testng webdriver

Top Members

Robert

Robert

  • 3 Questions
  • 1k Points
Luci

Luci

  • 5 Questions
  • 1k Points
Kevin O Brien

Kevin O Brien

  • 2 Questions
  • 1k Points

Explore

  • Home
  • Add group
  • Groups page
  • Communities
  • Questions
    • New Questions
    • Trending Questions
    • Must read Questions
    • Hot Questions
  • Polls
  • Tags
  • Badges
  • Users
  • Help

Footer

Softans

Softans is a social questions & Answers Engine which will help you establish your community and connect with other people.

About Us

  • Blog
  • Jobs
  • About Us
  • Meet The Team
  • Contact Us

Legal Stuff

Help

Follow

© 2021 Softans. All Rights Reserved
With Love by Softans.

Insert/edit link

Enter the destination URL

Or link to existing content

    No search term specified. Showing recent items. Search or use up and down arrow keys to select an item.