Forum

Αναζήτηση στο ms-office.gr

Πάμε!
ms-office.gr > Forum > Microsoft Excel > Excel - Ερωτήσεις / Απαντήσεις > [VBA] κώδικας κατασκευής συνδυασμών αριθμών

Excel - Ερωτήσεις / Απαντήσεις Ότι έχει σχέση με συναρτήσεις, μορφοποίηση, εκτυπώσεις γραφήματα κτλ.

Απάντηση στο θέμα

 

Εργαλεία Θεμάτων Τρόποι εμφάνισης
  #1  
Παλιά 07-08-18, 21:40
Όνομα: Δημήτρης
Έκδοση λογισμικού Office: Ms-Office 2003
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 26-08-2013
Μηνύματα: 8
Προεπιλογή κώδικας κατασκευής συνδυασμών αριθμών

Φίλοι του Forum γεια σας.
Έχω τον πιο κάτω κώδικα vba.

Sub Combinations()
Dim n As Integer, m As Integer, numcomb
numcomb = 0
n = InputBox("Number of items?", "Combinations")
m = InputBox("Taken how many at a time?", "Combinations")
Application.ScreenUpdating = False
Comb2 n, m, 1, ""
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Private Function Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String)
If m > n - k + 1 Then Exit Function
If m = 0 Then
ActiveCell = s
ActiveCell.Offset(1, 0).Select
Exit Function
End If
Comb2 n, m - 1, k + 1, s & k & " "
Comb2 n, m, k + 1, s
End Function

Θα ήθελα να ρωτήσω, αν αυτή η Function μπορεί να τροποποιηθεί, έτσι ώστε να αναγράφει το αποτέλεσμα σε ξεχωριστά συνεχόμενα κελιά. π.χ. Αντί για "1 2 3 4 5" στο κελί A1, να το αναγράφει στα κελιά A1,A2,A3,A4,A5

Ευχαριστώ πολύ, για όποια απάντηση.
Απάντηση με παράθεση
  #2  
Παλιά 07-08-18, 22:50
Το avatar του χρήστη Spirosgr
Συντονιστής
Όνομα: Σπύρος Τσιλιγιάννης
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2010, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 22-11-2011
Περιοχή: Αθήνα
Μηνύματα: 2.204
Προεπιλογή

Δοκίμασα με επιλεγμένο το Α1
n=5 & m=1
ακόμα με n=10 & m=2

Τρέχουμε το Combinations και
το αποτέλεσμα αναπτύσσεται στα κελιά a1,a2...aν όσο πρέπει...
Ποιό είναι το πρόβλημα;
__________________
Spirosgr
spirostsiligiannis@gmail.com
Απάντηση με παράθεση
  #3  
Παλιά 07-08-18, 23:56
Όνομα: Δημήτρης
Έκδοση λογισμικού Office: Ms-Office 2003
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 26-08-2013
Μηνύματα: 8
Προεπιλογή

Το πρόβλημα είναι κατ' αρχήν δικό μου, γιατί κατά λάθος έγραψα τα κελιά A1,A2,A3,A4,A5 αντί να γράψω A1,B1,C1,D1,E1, και ζητώ συγνώμη για το λάθος μου. Αυτό που θέλω τελικά είναι να εμφανίζετε σε ξεχωριστό κελί (οριζόντια) ο κάθε αριθμός του ίδιου συνδυασμού. π.χ. αν εμφανίζετε ο συνδυασμός "1,2,3,4,5" στο κελί A1, εγώ θέλω να εμφανίζετε ως εξής. A1=1,B1=2,C1=3,D1=4,E1=5.
Απάντηση με παράθεση
  #4  
Παλιά 08-08-18, 09:07
Όνομα: Γιώργος
Έκδοση λογισμικού Office: Ms-Office 2010
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 18-06-2010
Μηνύματα: 2.878
Προεπιλογή

Καλημέρα

Δημήτρη αυτό γίνεται, αλλά δημιουργεί προβλήματα.

Βλέπω ότι έχεις το office 2003, στο οποίο το πλήθος των στηλών είναι 256.

Αν θέλουμε τους συνδυασμούς των n ανά m, σε μία γραμμή, μπορούμε να καταχωρήσουμε το πολύ 256/m συνδυασμούς, που είναι πολύ λίγοι.

Αν έχουμε παραπάνω συνδυασμούς, που θα καταχωρηθούν;

Στις παρακάτω γραμμές;
Απάντηση με παράθεση
  #5  
Παλιά 08-08-18, 10:02
Όνομα: Δημήτρης
Έκδοση λογισμικού Office: Ms-Office 2003
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 26-08-2013
Μηνύματα: 8
Προεπιλογή

Καλημέρα Γιώργο, και ευχαριστώ για την απάντηση.
1) Έχω το Excel 2007
2) Oi 'n' αριθμοί θα είναι έως 30 το πολύ. Οι 'm' αριθμοί θα είναι από 5 έως 6
Παράδειγμα συνδυασμού με 'n' = 7 και 'm' = 5 (Συνημμένο αρχείο)
3) Αν υπάρχει πρόβλημα σε κάτι, αυτό είναι το πλήθος των γραμμών, και όχι των στηλών
(για μεγάλο αριθμό συνδυασμών).
Συνημμένα Αρχεία
Τύπος Αρχείου: xlsm Ρουτίνα Συνδιασμών αριθμών 2.xlsm (20,0 KB, 8 εμφανίσεις)
Απάντηση με παράθεση
  #6  
Παλιά 08-08-18, 10:30
Όνομα: Γιώργος
Έκδοση λογισμικού Office: Ms-Office 2010
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 18-06-2010
Μηνύματα: 2.878
Προεπιλογή

Δημήτρη τώρα κατάλαβα τι θέλεις.

Δοκίμασε τον κώδικα:

Κώδικας:
Option Explicit
Dim x() As Variant, R As Long, mm As Long
Sub Combinations()
    Const startCel As String = "A1" 'Το κελί στο οποίο θα γίνει η 1η καταχώρηση
    Dim n As Integer, m As Integer, numcomb, rng As Range, numC As Long
    
    numcomb = 0
    n = InputBox("Number of items?", "Combinations")
    m = InputBox("Taken how many at a time?", "Combinations")
    mm = m
    Application.ScreenUpdating = False
    numC = Application.WorksheetFunction.Combin(n, m)
    Set rng = Range(startCel)
    ReDim x(1 To numC, 1 To m) As Variant
    R = 0
    Comb2 n, m, 1, ""
    rng.Resize(UBound(x, 1) + 5, mm + 2).ClearContents
    rng.Resize(UBound(x, 1), mm).Value = x
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Private Function Comb2(ByVal n As Integer, ByVal m As Integer, _
                       ByVal k As Integer, ByVal s As String)
    Dim j As Long
    If m > n - k + 1 Then Exit Function
    If m = 0 Then
        R = R + 1
        For j = 1 To mm
            x(R, j) = Split(s, " ")(j - 1)
        Next
        Exit Function
    End If
    Comb2 n, m - 1, k + 1, s & k & " "
    Comb2 n, m, k + 1, s
End Function
Απάντηση με παράθεση
  #7  
Παλιά 08-08-18, 10:42
Όνομα: Δημήτρης
Έκδοση λογισμικού Office: Ms-Office 2003
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 26-08-2013
Μηνύματα: 8
Προεπιλογή

Γιώργο.....αυτό είναι!!!
Ευχαριστώ πολύ.
Απάντηση με παράθεση
  #8  
Παλιά 08-08-18, 10:57
Όνομα: Γιώργος
Έκδοση λογισμικού Office: Ms-Office 2010
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 18-06-2010
Μηνύματα: 2.878
Προεπιλογή

Καλή συνέχεια Δημήτρη.
Απάντηση με παράθεση
  #9  
Παλιά 08-08-18, 12:20
Όνομα: Γιώργος
Έκδοση λογισμικού Office: Ms-Office 2010
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική
 
Εγγραφή: 18-06-2010
Μηνύματα: 2.878
Προεπιλογή

Δημήτρη, για να κάνουμε σωστή δουλειά, άλλαξε την ομώνυμη ρουτίνα του προηγούμενου κώδικα με την :

Κώδικας:
Sub Combinations()
    Const startCel As String = "A1"    'Το κελί στο οποίο θα γίνει η 1η καταχώρηση
    Dim n As Integer, m As Integer, rng As Range, numCbn As Long

    n = InputBox("Number of items?", "Combinations")
    m = InputBox("Taken how many at a time?", "Combinations")
    mm = m
    Application.ScreenUpdating = False
    numCbn = Application.WorksheetFunction.Combin(n, m)
    If numCbn >= Rows.Count - 2 - Range(startCel).Row Then
        MsgBox "Το πλήθος των συνδυασμών: " & Format(numCbn, "#,###") & vbCrLf & _
               "υπερβαίνει το πλήθος των γραμμών του φύλλου", vbCritical
    Else
        Set rng = Range(startCel)
        ReDim x(1 To numCbn, 1 To m) As Variant
        R = 0
        Comb2 n, m, 1, ""
        rng.Resize(UBound(x, 1) + 2, mm + 2).ClearContents
        rng.Resize(UBound(x, 1), mm).Value = x
    End If
End Sub
Στον κώδικα ελέγχεται αν το πλήθος των συνδυασμών είναι μικρότερο από το πλήθος των γραμμών του φύλλου και αν δεν είναι εμφανίζεται μήνυμα και οι συνδυασμοί δεν υπολογίζονται

Χωρίς τον έλεγχο θα υπολογίζονταν οι συνδυασμοί (θα απαιτούσε κάποιο χρόνο) και ο κώδικας θα χτυπούσε..
Απάντηση με παράθεση
  #10  
Παλιά 09-08-18, 00:50
Όνομα: Δημήτρης
Έκδοση λογισμικού Office: Ms-Office 2003
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 26-08-2013
Μηνύματα: 8
Προεπιλογή

Γιώργο καλημέρα
Επανέρχομαι στο θέμα, για μια σημαντική βελτίωση της ρουτίνας, αν αυτό είναι εφικτό.
Τελικά ....όπως το λες. Βγάζει error overflow ή out of memory, όταν βάζω πολλούς αριθμούς για δημιουργία συνδυασμών.
Αναρωτιέμαι αν αυτό μπορεί να εξαλειφθεί, αν υπολογίζει και εμφανίζει έναν συνδυασμό στην ίδια θέση κάθε φορά, π.χ. ξεκινώντας πάντα κάθε συνδυασμό από το κελί "A1" και όχι να κρατά στη μνήμη όλους τους συνδυασμούς, και να τους εμφανίζει όλους μαζί, με αποτέλεσμα το overflow ή out of memory.
Αυτό θα ήταν τέλειο.
Για να καταλάβεις καλύτερα τι θέλω να κάνω, σου στέλνω αυτό το αρχείο, που μου δίνει κάποια στατιστικά δεδομένα των 'χ' τελευταίων κληρώσεων για το παιχνίδι του ΟΠΑΠ 'ΤΖΟΚΕΡ'.
Στο φύλλο αυτό, και στο κελί 'B8' τον αριθμό των τελευταίων 'χ' κληρώσεων από τις οποίες θέλω να πάρω στατιστικά στοιχεία.
Επεξήγηση του προγράμματος
Στις στήλες C:G είναι οι κληρώσεις.
Στις στήλες KH:KQ από τη γραμμή 12 και κάτω, εμφανίζει αν έχουμε πιάσει 0 ή 1 ή 2 ή 3 ή 4 ή 5 αριθμούς από την αντίστοιχη κλήρωση της ίδιας γραμμής, σε συνδυασμό με τούς επιλεγμένους αριθμούς της περιοχής IX1:JI10.
Κάθε χρωματική αλλαγή στις γραμμές 1 έως 10 αφορά διαφορετικές αριθμοσειρές, που τα αποτελέσματα τις στατιστικής ανάλυσης για κάθε αριθμοσειρά φαίνονται στην αντίστοιχη στήλη ίδιου χρώματος.
Στην περιοχή KH1:KQ6 εμφανίζονται τα συγκεντρωτικά αποτελέσματα τις στατιστικής ανάλυσης για κάθε αριθμοσειρά. π.χ στο κελί 'KQ6' εμφανίζει το πόσες φορές βγήκε 5αρη για την αριθμοσειρά της γραμμής 1 (με μπλε σκούρο χρώμα).
Για να καταλάβεις καλύτερα, μπορείς να αλλάξεις, ή να προσθέσεις ή να αφαιρέσεις κάποιους αριθμούς από κάποια αριθμοσειρά, και να δεις τα αποτελέσματα.
Σημείωση:
Τα πολλά κενά κελιά μεταξύ κληρώσεων και στατιστικών δεδομένων, οφείλονται στο ότι διέγγραψα όλα τα υπόλοιπα στατιστικά στοιχεία, για καλύτερη κατανόηση του προγράμματος.

Αυτό που θέλω να κάνει η ρουτίνα combinations.
1) Να εμφανίζει έναν συνδυασμό κάθε φορά, ξεκινώντας από το κελί 'IX1'
2) Να περιμένει μέχρι να γίνει ο υπολογισμός των συναρτήσεων στο φύλλο
3) Να διαβάζει την τιμή του κελιού 'KQ6", και να την συγκρίνει με την προηγούμενη τιμή του ίδιου
κελιού. Κάθε φορά που η τιμή του κελιού 'KQ6" είναι μεγαλύτερη από την τιμή πού έχει στη μνήμη
η ρουτίνα, να αντιγράφει την αριθμοσειρα της περιοχής 'IX1:KF1' στην περιοχή 'IX11:KF11', και στο κελί 'KG11' να αναγράφει την αντίστοιχη τιμή του κελιού 'KQ6". ΄
Με τον τρόπο αυτό θα έχω στην περιοχή 'IX11:KF11' τον καλύτερο συνδυασμό που έχει προκύψει, για την συγκεκριμένη αριθμοσειρά.

Ελπίζω να έγινα πιο σαφείς αυτή τη φορά, και φυσικά ελπίζω στη βοήθειά σας.

Υ.Γ. Καταλαβαίνω ότι ο χρόνος εκτέλεσης της ρουτίνας θα είναι πολύ μεγάλος, αλλά δεν με πειράζει.
Συνημμένα Αρχεία
Τύπος Αρχείου: zip Πρόγραμμα Tζόκερ test29-e-TEST(OK).zip (311,7 KB, 9 εμφανίσεις)
Απάντηση με παράθεση
Απάντηση στο θέμα

Εργαλεία Θεμάτων
Τρόποι εμφάνισης

Δικαιώματα - Επιλογές
Δε μπορείτε να δημοσιεύσετε νέα μηνύματα
Δε μπορείτε να δημοσιεύσετε απαντήσεις
Δεν μπορείτε να επισυνάψετε αρχεία
Δεν μπορείτε να επεξεργαστείτε τα μηνύματα σας

Ο κώδικας ΒΒ είναι σε λειτουργία
Τα Smilies είναι σε λειτουργία
Ο κώδικας [IMG] είναι σε λειτουργία
Ο κώδικας HTML είναι εκτός λειτουργίας
Trackbacks are εκτός λειτουργίας
Pingbacks are εκτός λειτουργίας
Refbacks are εκτός λειτουργίας


Παρόμοια Θέματα

Θέμα Δημιουργός Forum Απαντήσεις Τελευταίο Μήνυμα
Δημιουργία όλων των συνδυασμών, μεταθέσεων, διατάξεων και υποσυνόλων. kapetang Access samples - Χρήσιμα αρχεία & παραδείγματα 0 19-08-17 20:41
[Γενικά] Βοήθεια κατασκευής πινάκα. αγγελος23 Excel - Ερωτήσεις / Απαντήσεις 6 24-05-16 16:59
[Συναρτήσεις] Δημιουργία συνδυασμών gr8styl Excel samples - Χρήσιμα αρχεία & παραδείγματα 0 27-04-12 20:29
[Γενικά] Εμφάνιση συνδυασμών PANIK Excel - Ερωτήσεις / Απαντήσεις 4 23-04-12 21:04
Δημιουργία συνδυασμών πλήκτρων στην Access Giorgos Access - Ερωτήσεις / Απαντήσεις 2 30-12-09 16:28


Η ώρα είναι 11:03.