CODEWITHSUNDEEP
pandasvba
Calle
Calle

Reputation: 153

Concatanating values from each columns with values from other columns

I would like to ask you for help with creating a VBA code or python script that would combine all information in below screen like following:

There are 10 columns with in each there is one digit (or a dot). I would like to create a macro that would combine all possible combinations and created a list for me like:

KMFD...BAK 
KMHD...BAK 
KMJD...BAK 
KMFD...CAK 
KMFD...CAK 
KMHD...CAK 
KMJD...CAK 
.... 
.... 
....

so in short to display me a concataned list whre every digit in each column is combined with every single digit from other columns.

Is that achievable with a macro?

Thank you in advance for any tips.

I would like to creata a VBA

enter image description here

Upvotes: 0

Views: 36

Answers (1)

Tim Williams
Tim Williams

Reputation: 166825

From: VBA - Write all possible combinations of 4 columns of data

enter image description here

Sub ListCombinations()

    Dim col As New Collection
    Dim c As Range, sht As Worksheet, res
    Dim i As Long, arr, numCols As Long

    Set sht = ActiveSheet
   'lists begin in A2, B2, C2, etc
    For Each c In sht.Range("A2:J2").Cells
        col.Add Application.Transpose(sht.Range(c, sht.Cells(Rows.Count, c.Column).End(xlUp)))
        numCols = numCols + 1
    Next c
    
    res = Combine(col, "~~")
    
    For i = 0 To UBound(res)
        arr = Split(res(i), "~~")
        sht.Range("L1").Offset(i, 0).Resize(1, numCols) = arr
    Next i

End Sub


'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()

    Dim rv() As String
    Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
    Dim t As Long, i As Long, n As Long, ub As Long
    Dim numIn As Long, s As String, r As Long, v, tmp()

    numIn = col.Count
    ReDim pos(1 To numIn)
    ReDim lbs(1 To numIn)
    ReDim ubs(1 To numIn)
    ReDim lengths(1 To numIn)
    t = 0
    For i = 1 To numIn  'calculate # of combinations, and cache bounds/lengths
        'handle cases where only one value in a column (not passed in as array)
        If Not TypeName(col(i)) Like "*()" Then
            ReDim tmp(1 To 1)
            tmp(1) = col(i)
            col.Remove i
            If i > col.Count Then
                col.Add tmp
            Else
                col.Add tmp, Before:=i
            End If
        End If
        lbs(i) = LBound(col(i))
        ubs(i) = UBound(col(i))
        lengths(i) = (ubs(i) - lbs(i)) + 1
        pos(i) = lbs(i)
        t = IIf(t = 0, lengths(i), t * lengths(i))
    Next i
    ReDim rv(0 To t - 1) 'resize destination array

    For n = 0 To (t - 1)
        s = ""
        For i = 1 To numIn
            s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
        Next i
        rv(n) = s

        For i = numIn To 1 Step -1
            If pos(i) <> ubs(i) Then   'Not done all of this array yet...
                pos(i) = pos(i) + 1    'Increment array index
                For r = i + 1 To numIn 'Reset all the indexes
                    pos(r) = lbs(r)    '   of the later arrays
                Next r
                Exit For
            End If
        Next i
    Next n

    Combine = rv
End Function

Upvotes: 1

Related Questions