Μετάβαση στο κύριο περιεχόμενο

Πώς να παραθέσω όλους τους πιθανούς συνδυασμούς από μία στήλη στο Excel;

Εάν θέλετε να επιστρέψετε όλους τους πιθανούς συνδυασμούς από δεδομένα μιας στήλης για να λάβετε το αποτέλεσμα όπως φαίνεται στο παρακάτω στιγμιότυπο οθόνης, έχετε κάποιους γρήγορους τρόπους για να αντιμετωπίσετε αυτήν την εργασία στο Excel;

Καταγράψτε όλους τους πιθανούς συνδυασμούς από μία στήλη με τύπους

Καταγράψτε όλους τους πιθανούς συνδυασμούς από μία στήλη με κωδικό VBA


Καταγράψτε όλους τους πιθανούς συνδυασμούς από μία στήλη με τύπους

Οι παρακάτω τύποι πίνακα μπορούν να σας βοηθήσουν να επιτύχετε αυτήν τη δουλειά, κάντε βήμα προς βήμα:

1. Αρχικά, θα πρέπει να δημιουργήσετε δύο βοηθητικά κελιά τύπου. Στο κελί C1, εισαγάγετε τον παρακάτω τύπο και πατήστε Ctrl + Shift + Εισαγωγή κλειδιά για το αποτέλεσμα:

=MAX(LEN(A2:A6))
Note: Σε αυτόν τον τύπο, A2: A6 είναι η λίστα των κελιών που θέλετε να καταχωρίσετε τους συνδυασμούς τους.

2. Στο κελί C2, εισαγάγετε τον ακόλουθο τύπο και πατήστε Ctrl + Shift + Εισαγωγή τα πλήκτρα μαζί για να λάβετε το δεύτερο αποτέλεσμα, δείτε στιγμιότυπο οθόνης:

=CONCAT(A2:A6&REPT(" ",C2-LEN(A2:A6)))
Note: Σε αυτόν τον τύπο, A2: A6 είναι η λίστα των κελιών που θέλετε να καταχωρίσετε τους συνδυασμούς τους, C2 είναι το κελί περιέχει τον τύπο που δημιουργήσατε στο βήμα 1.

3. Στη συνέχεια, αντιγράψτε και επικολλήστε τον ακόλουθο τύπο στο κελί D2 και πατήστε Ctrl + Shift + Εισαγωγή πλήκτρα μαζί για να λάβετε το πρώτο αποτέλεσμα, δείτε το στιγμιότυπο οθόνης:

=IF(ROW()>2^(COUNTA(A$2:A$6)),"",TEXTJOIN(" + ",TRUE,IF(MID(TEXT(DEC2BIN(ROW()-1),REPT("0",COUNTA($A$2:$A$6))),ROW(INDIRECT("1:"&COUNTA($A$2:$A$6))),1)+0,TRIM(MID($C$3,(ROW(INDIRECT("1:"&COUNTA($A$2:$A$6)))-1)*$C$2+1,$C$2)),"")))
Note: Σε αυτόν τον τύπο, A2: A6 είναι η λίστα των κελιών που θέλετε να καταχωρίσετε τους συνδυασμούς τους, C2 είναι το κελί που περιέχει τον τύπο που δημιουργήσατε στο βήμα 1, C3 είναι το κελί με τον τύπο που δημιουργήσατε στο βήμα 2, το + Ο χαρακτήρας είναι το διαχωριστικό για να διαχωρίσετε τους συνδυασμούς, μπορείτε να τους αλλάξετε ανάλογα με τις ανάγκες σας.

4. Στη συνέχεια, επιλέξτε αυτό το κελί τύπου και σύρετε τη λαβή πλήρωσης προς τα κάτω μέχρι να εμφανιστούν κενά κελιά. Τώρα, μπορείτε να δείτε ότι όλοι οι συνδυασμοί των καθορισμένων δεδομένων στηλών εμφανίζονται όπως φαίνεται στην παρακάτω επίδειξη:

Note: Αυτός ο τύπος είναι διαθέσιμος μόνο σε Office 2019, 365 και νεότερες εκδόσεις.

Καταγράψτε όλους τους πιθανούς συνδυασμούς από μία στήλη με κωδικό VBA

Οι παραπάνω τύποι είναι διαθέσιμοι μόνο για νεότερες εκδόσεις του Excel, εάν έχετε παλαιότερες εκδόσεις του Excel, ο παρακάτω κώδικας VBA μπορεί να σας κάνει τη χάρη.

1. Τύπος Alt + F11 ταυτόχρονα για να ανοίξετε το Microsoft Visual Basic για εφαρμογές παράθυρο.

2. Στη συνέχεια, κάντε κλικ στο κουμπί Κύριο θέμα > Μονάδα μέτρησης, αντιγράψτε και επικολλήστε τον παρακάτω κώδικα VBA στο παράθυρο.

Κωδικός VBA: Καταχωρίστε όλους τους πιθανούς συνδυασμούς από μία στήλη

Sub ConnectArr()
'Updateby ExtendOffice
Dim xDValue As Variant
Dim xOutRg As Range
Dim xDictionary As Object
Dim xF As Long
Dim xChar As String
xDValue = Range("A2:A6").Value 'the data range
Set xOutRg = Range("C1") 'output range
xChar = "," 'separator
For xF = 1 To UBound(xDValue)
    Set xDictionary = CreateObject("Scripting.Dictionary")
    xDictionary(0) = "Sets of " & xF
    Call ConnectValue(xDValue, xDictionary, 0, xF, 0, "", xChar)
    xOutRg.Offset(0, xF - 1).Resize(xDictionary.Count).Value = WorksheetFunction.Transpose(xDictionary.Items)
    Set xDictionary = Nothing
Next
End Sub
Sub ConnectValue(ByRef pDValue, ByRef pDictionary, ByRef pLevel, ByVal pMaxLevel, ByVal pIndex, ByVal pValue, ByVal pChar)
Dim xF As Long
If pLevel = pMaxLevel Then
    pDictionary(pDictionary.Count + 1) = pValue
    Exit Sub
End If
For xF = pIndex + 1 To UBound(pDValue)
    If pValue = "" Then
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pDValue(xF, 1), pChar)
    Else
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pValue & pChar & pDValue(xF, 1), pChar)
    End If
Next
End Sub
Note: Στον παραπάνω κωδικό:
  • A2: A6: είναι η λίστα των δεδομένων που θέλετε να χρησιμοποιήσετε.
  • C1: είναι το κελί εξόδου.
  • ,: ο οριοθέτης για τον διαχωρισμό των συνδυασμών.

3. Και μετά, πατήστε F5 κλειδί για την εκτέλεση αυτού του κώδικα. Όλοι οι συνδυασμοί από τη μεμονωμένη στήλη παρατίθενται όπως φαίνεται στο παρακάτω στιγμιότυπο οθόνης:

Τα καλύτερα εργαλεία παραγωγικότητας γραφείου

🤖 Kutools AI Aide: Επανάσταση στην ανάλυση δεδομένων με βάση: Ευφυής Εκτέλεση   |  Δημιουργία κώδικα  |  Δημιουργία προσαρμοσμένων τύπων  |  Αναλύστε δεδομένα και δημιουργήστε γραφήματα  |  Επίκληση Λειτουργιών Kutools...
Δημοφιλή χαρακτηριστικά: Εύρεση, επισήμανση ή αναγνώριση διπλότυπων   |  Διαγραφή κενών γραμμών   |  Συνδυάστε στήλες ή κελιά χωρίς απώλεια δεδομένων   |   Γύρος χωρίς φόρμουλα ...
Σούπερ Αναζήτηση: VLookup πολλαπλών κριτηρίων    VLookup πολλαπλών τιμών  |   VLookup σε πολλά φύλλα   |   Ασαφής αναζήτηση ....
Σύνθετη αναπτυσσόμενη λίστα: Γρήγορη δημιουργία αναπτυσσόμενης λίστας   |  Εξαρτημένη αναπτυσσόμενη λίστα   |  Πολλαπλή αναπτυσσόμενη λίστα ....
Διαχειριστής στήλης: Προσθέστε έναν συγκεκριμένο αριθμό στηλών  |  Μετακίνηση στηλών  |  Εναλλαγή κατάστασης ορατότητας κρυφών στηλών  |  Συγκρίνετε εύρη και στήλες ...
Επιλεγμένα Χαρακτηριστικά: Εστίαση πλέγματος   |  Προβολή σχεδίου   |   Μεγάλη Formula Bar    Διαχείριση βιβλίου εργασίας & φύλλου   |  Βιβλιοθήκη πόρων (Αυτόματο κείμενο)   |  Επιλογή ημερομηνίας   |  Συνδυάστε φύλλα εργασίας   |  Κρυπτογράφηση/Αποκρυπτογράφηση κελιών    Αποστολή email ανά λίστα   |  Σούπερ φίλτρο   |   Ειδικό φίλτρο (φίλτρο με έντονη γραφή/πλάγια γραφή/διαγραφή...) ...
Κορυφαία 15 σύνολα εργαλείων12 Κείμενο Εργαλεία (Προσθήκη κειμένου, Κατάργηση χαρακτήρων, ...)   |   50 + Διάγραμμα Τύποι (Gantt διάγραμμα, ...)   |   40+ Πρακτικό ΜΑΘΗΜΑΤΙΚΟΙ τυποι (Υπολογίστε την ηλικία με βάση τα γενέθλια, ...)   |   19 Εισαγωγή Εργαλεία (Εισαγωγή κωδικού QR, Εισαγωγή εικόνας από το μονοπάτι, ...)   |   12 Μετατροπή Εργαλεία (Αριθμοί σε λέξεις, Μετατροπή Συναλλάγματος, ...)   |   7 Συγχώνευση & διαχωρισμός Εργαλεία (Σύνθετες σειρές συνδυασμού, Διαίρεση κελιών, ...)   |   ... κι αλλα

Αυξήστε τις δεξιότητές σας στο Excel με τα Kutools για Excel και απολαύστε την αποτελεσματικότητα όπως ποτέ πριν. Το Kutools για Excel προσφέρει πάνω από 300 προηγμένες δυνατότητες για την ενίσχυση της παραγωγικότητας και την εξοικονόμηση χρόνου.  Κάντε κλικ εδώ για να αποκτήσετε τη δυνατότητα που χρειάζεστε περισσότερο...

Περιγραφή


Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη

  • Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
  • Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
  • Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
Comments (11)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Hi Skyyang,

Not sure if you are still active on this thread. But just taking a chance in case. I am not very familiar with VBA coding and am stuck in a situation where I need code to tackle one situation in my project. I need to create a unique combination from the list of variables mentioned in "SHEET1" cells "A2:A20". The combination will be of 2 variables listed in the row starting from A2 in SHEET2. And a list with 3 variable combinations listed in the row starting from A2 in SHEET3.

Thanks in advance.
This comment was minimized by the moderator on the site
Hello,
Nice job!
But I'm interested to find just the "Sets of 2", as in your example, e.g. a list of players who have to play matches with each other :).
Thank you.
This comment was minimized by the moderator on the site
Hello, Iulian,
To solve your problem, please apply the below code:
Note: your names should be start at A2 cell, and the result will be placed at C2 cell.
Sub name_by_name()
    Dim i As Long, j As Long, lr As Long
    With ActiveSheet
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To lr
            For j = i + 1 To lr
                .Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) = _
                  .Cells(i, 1).Value & ", " & .Cells(j, 1).Value
            Next j
        Next i
    End With
End Sub


Please have a try, hope it can help you!

https://www.extendoffice.com/images/stories/comments/comment-skyyang/2023-comment/combinations-1.png
This comment was minimized by the moderator on the site
Hello, I have a list of 30 items in a column and the code doesn't seem to be able to handle that, what is the max number of items allowed for the code to work? is there a way to make a long list work?
This comment was minimized by the moderator on the site
Hello, Lynn,
Yes, as you said, if the number of cells are greater than 20, the code will not work well.
Sorry for that inconvenience.

With this code, it will pop out an alert if the number of cells is greater than 20.
Sub ConnectArr()
'Updateby ExtendOffice
Dim xDValue As Variant
Dim xOutRg As Range
Dim xDictionary As Object
Dim xF As Long
Dim xChar As String
Dim xAddress As String
xAddress = "A1:A20" 'the data range
If Range(xAddress).Count > 20 Then
    MsgBox "The number of cells can't greater than 20!"
    Exit Sub
End If
xDValue = Range(xAddress).Value
Set xOutRg = Range("C1") 'output range
xChar = "," 'separator
For xF = 1 To UBound(xDValue)
    Set xDictionary = CreateObject("Scripting.Dictionary")
    xDictionary(0) = "Sets of " & xF
    Call ConnectValue(xDValue, xDictionary, 0, xF, 0, "", xChar)
    xOutRg.Offset(0, xF - 1).Resize(xDictionary.Count).Value = WorksheetFunction.Transpose(xDictionary.Items)
    Set xDictionary = Nothing
Next
End Sub
Sub ConnectValue(ByRef pDValue, ByRef pDictionary, ByRef pLevel, ByVal pMaxLevel, ByVal pIndex, ByVal pValue, ByVal pChar)
Dim xF As Long
If pLevel = pMaxLevel Then
    pDictionary(pDictionary.Count + 1) = pValue
    Exit Sub
End If
For xF = pIndex + 1 To UBound(pDValue)
    If pValue = "" Then
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pDValue(xF, 1), pChar)
    Else
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pValue & pChar & pDValue(xF, 1), pChar)
    End If
Next
End Sub

This comment was minimized by the moderator on the site
I really like the method but values bottom out at the 511th row and you get #NUM! if you have more than 6 entries in column A. I'm wondering if someone might consider helping me to adjust the formula so that the resulting values calculate beyond the 511th row? Thank you very much! =)
This comment was minimized by the moderator on the site
Hello,
Yes, as you said, the formula will stop work in row 511. So, here, you can appy the VBA code in this article.
Or if you want to list all possible combinations into single one column, please apply the below code:
Note: In the code, A2 is the first cell contains the data you want to use, you should change the cell reference A2 and A to your own. After running the code, all combinations will be listed in the next column of the data list.
Sub allcombination()
Dim Ray As Variant, n As Long, nn As Long, Allnum As String, c As Long
Dim Res As Long, obit, oSt, ipc, Tot As Long, oPst As Long, sNum As String
Ray = Application.Transpose(Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)))
sNum = Join(Evaluate("TRANSPOSE(ROW(" & 1 & ":" & UBound(Ray) & "))"), ",")
For n = 1 To UBound(Ray)
    Tot = Tot + Application.Combin(UBound(Ray), n)
Next n
ReDim Oval(1 To Tot)
ReDim nRay(1 To Tot - UBound(Ray))
Do Until Allnum = sNum
   If c < UBound(Ray) Then
       For n = 1 To UBound(Ray)
             c = c + 1: Oval(c) = n
       Next n
   Else
       For n = 1 To UBound(Ray)
             Res = Res + 1
             obit = Oval(Res)
             oSt = Split(obit, ",")(UBound(Split(obit, ",")))
                For nn = oSt + 1 To UBound(Ray)
                    c = c + 1
                    Allnum = obit & "," & nn
                    Oval(c) = Allnum
                Next nn
         Next n
   End If
Loop
Dim s As Variant, nStr As String
    For oPst = UBound(Ray) + 1 To UBound(Oval)
        For Each s In Split(Oval(oPst), ",")
            nStr = nStr & IIf(nStr = "", Ray(s), "," & Ray(s))
        Next s
            nRay(oPst - UBound(Ray)) = nStr: nStr = ""
  Next oPst
Range("B1").Resize(UBound(nRay)).Value = Application.Transpose(nRay)
End Sub

Please have a try, hope it can help you! 🙂
This comment was minimized by the moderator on the site
Dear skyyang:

Thank you very much for your help and the code. It's invaluable and I'm grateful.

I'm relatively new to VB scripting, consequently not very adept at coding the language.

Just a point or two:

- Your suggested code doesn't generate single entries (e.g. Ruby, or...)
- The original ordering as highlighted in the animated graphic in Step 4 disappeared.

I will go through your code to try my hand at calibrating it so that the above points are outputted, but I was wondering if you had any quick advice or suggestion(s) that could address them.

Thank you again for your kind help. I really appreciate it. =)

My best.
This comment was minimized by the moderator on the site
Dear skyyang:

First, thank you very much for your code solution. I am grateful! =)

I wrote a reply yesterday but the system seems not to have posted it for unknown reasons. I hope this one gets through.

Your code generates output that I am interested in. I had just a couple of observations and then a question:

1) The code doesn't generate the individual entries alone.
2) The original ordering seen in the animated graphic in Step 4 is lost.

From your code is there a way to also include the single entries and to mirror the original ordering format from Step 4. I'm rather new to VB scripting.

Again, thank you so much for your invaluable help. I really appreciate it.

My best.
This comment was minimized by the moderator on the site
Dear skyyang:

This is wonderful. Thank you, this helps me out immensely. I am very grateful.

Just a couple observations I noticed after generating the VB code you provided was that the singletons (for lack of a better term), like just "Ruby", would get omitted, and the resulting (columnal) ordering no longer corresponded to the original ordering generated in Step 4 animated graphic.

Do you happen to have any quick suggestions about how I could tweak your code to also include the "singletons" and for matching the same ordering as in Step 4? I will try to wrangle the workaround but regrettably I'm fairly new to VB scripting.

Thanks again! I really appreciate it.

My best. =)
This comment was minimized by the moderator on the site
Hello, ffuuzz
In this case, you can try the vba code in our article, all possible combinations will be listed into separated columns, please try:
Sub ConnectArr()
'Updateby ExtendOffice
Dim xDValue As Variant
Dim xOutRg As Range
Dim xDictionary As Object
Dim xF As Long
Dim xChar As String
xDValue = Range("A2:A6").Value 'the data range
Set xOutRg = Range("C1") 'output range
xChar = "," 'separator
For xF = 1 To UBound(xDValue)
    Set xDictionary = CreateObject("Scripting.Dictionary")
    xDictionary(0) = "Sets of " & xF
    Call ConnectValue(xDValue, xDictionary, 0, xF, 0, "", xChar)
    xOutRg.Offset(0, xF - 1).Resize(xDictionary.Count).Value = WorksheetFunction.Transpose(xDictionary.Items)
    Set xDictionary = Nothing
Next
End Sub
Sub ConnectValue(ByRef pDValue, ByRef pDictionary, ByRef pLevel, ByVal pMaxLevel, ByVal pIndex, ByVal pValue, ByVal pChar)
Dim xF As Long
If pLevel = pMaxLevel Then
    pDictionary(pDictionary.Count + 1) = pValue
    Exit Sub
End If
For xF = pIndex + 1 To UBound(pDValue)
    If pValue = "" Then
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pDValue(xF, 1), pChar)
    Else
        Call ConnectValue(pDValue, pDictionary, pLevel + 1, pMaxLevel, xF, pValue & pChar & pDValue(xF, 1), pChar)
    End If
Next
End Sub
There are no comments posted here yet
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations