将每列中的值与其他列中的值连接起来

Question

我想请你帮忙创建一个 VBA 代码或 python 脚本，它将下面屏幕中的所有信息结合起来，如下所示：

有 10 列，每列有一个数字（或一个点）。我想创建一个宏来组合所有可能的组合并为我创建一个列表，例如：

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

简而言之，向我展示一个串联列表，其中每列中的每个数字都与其他列中的每个数字组合在一起。

这可以通过宏来实现吗？

提前感谢您的任何提示。

我想创建一个 VBA

Answer 1

发件人：VBA - Write all possible combinations of 4 columns of data

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