Neden çoklu ardışık olmayan eşit koşullar vba'da çalışmıyor?

Question

Aşağıdaki sözdiziminin neden VBA'da olacağını düşündüğüm şekilde çalışmadığını ve bunu sağlamak için ne yapmam gerektiğini merak ettim;

For a = 1 To 10 
    For b = 1 To 10 
     For c = 1 To 10 
      If a <> b <> c Then 
       MsgBox (a & " " & b & " " & c) 
      End If 
     Next c 
    Next b 
Next a 

Bu hala manuel ile elde edilebilir basitleştirilmiş bir örnektir, geçerli: 55 eşitsiz koşullarda olanaksız kılan

if a<>b and b<>c and c<>a then 

Ama benim asıl amaçlanan kod 10 gibi değişkenleri sahip birden çok kez, ya da yazım hatası yazmam mümkün. Bence daha verimli bir yol var ama onu bulamadım.

Ps. Amacım, tüm değişkenler benzersiz olduğunda yalnızca bir mesaj kutusu açmaktır.

muhtemelen çok daha verimli daha yapılabilir ama benim hedefe almış:

For a = 1 To 10 
    check(a) = True 
    For b = 1 To 10 
     If check(b) = False Then 
     check(b) = True 
     For c = 1 To 10 
      If check(c) = False Then 
       check(c) = True 
       For d = 1 To 10 
        If check(d) = False Then 
         check(d) = True 
         For e = 1 To 10 
          If check(e) = False Then 
           check(e) = True 
           MsgBox (a & " " & b & " " & c & " " & d & " " & e) 
          End If 
          check(e) = False 
          check(a) = True 
          check(b) = True 
          check(c) = True 
          check(d) = True 
         Next e 
        End If 
        check(d) = False 
        check(a) = True 
        check(b) = True 
        check(c) = True 
       Next d 
      End If 
      check(c) = False 
      check(a) = True 
      check(b) = True 


     Next c 
     End If 
     check(b) = False 
     check(a) = True 

    Next b 
Next a 

Answer 1

Burada, permütasyonları sıralamak için Johnson-Trotter algorithm'un bir uygulaması vardır. Travel Salesman Problemine kaba kuvvetli çözümlerle uğraşırken yazdığımın küçük bir modifikasyonu. Çok fazla bellek tüketebilecek 2 boyutlu bir dizi döndürdüğünü unutmayın. Tekrar yerleştirmek mümkündür, böylece permütasyonların depolanmasından ziyade tüketildiği bir alttır. Sadece kodun alt kısmına yakınını (burada geçerli izin, perm, dizide perms dizisinde saklanır), permutasyonu kullanan kodla değiştirin. gibi çıkış göz

Sub test() 
    Range("A1:G5040").Value = Permutations(7) 
    Dim A As Variant, i As Long, s As String 
    A = Permutations(10) 
    For i = 1 To 10 
     s = s & " " & A(3628800, i) 
    Next i 
    Debug.Print s 
End Sub 

ilk 20 satır:

Function Permutations(n As Long) As Variant 
'implements Johnson-Trotter algorithm for 
'listing permutations. Returns results as a variant array 
'Thus not feasible for n > 10 or so 

    Dim perm As Variant, perms As Variant 
    Dim i As Long, j As Long, k As Long, r As Long, D As Long, m As Long 
    Dim p_i As Long, p_j As Long 
    Dim state As Variant 

    m = Application.WorksheetFunction.Fact(n) 
    ReDim perm(1 To n) 
    ReDim perms(1 To m, 1 To n) As Integer 
    ReDim state(1 To n, 1 To 2) 'state(i,1) = where item i is currently in perm 
           'state(i,2) = direction of i 

    k = 1 'will point to current permutation 
    For i = 1 To n 
     perm(i) = i 
     perms(k, i) = i 
     state(i, 1) = i 
     state(i, 2) = -1 
    Next i 
    state(1, 2) = 0 
    i = n 'from here on out, i will denote the largest moving 
      'will be 0 at the end 
    Do While i > 0 
     D = state(i, 2) 
     'swap 
     p_i = state(i, 1) 
     p_j = p_i + D 
     j = perm(p_j) 
     perm(p_i) = j 
     state(i, 1) = p_j 
     perm(p_j) = i 
     state(j, 1) = p_i 
     p_i = p_j 
     If p_i = 1 Or p_i = n Then 
      state(i, 2) = 0 
     Else 
      p_j = p_i + D 
      If perm(p_j) > i Then state(i, 2) = 0 
     End If 
     For j = i + 1 To n 
      If state(j, 1) < p_i Then 
       state(j, 2) = 1 
      Else 
       state(j, 2) = -1 
      End If 
     Next j 
     'now find i for next pass through loop 
     If i < n Then 
      i = n 
     Else 
      i = 0 
      For j = 1 To n 
       If state(j, 2) <> 0 And j > i Then i = j 
      Next j 
     End If 
     'record perm in perms: 
     k = k + 1 
     For r = 1 To n 
      perms(k, r) = perm(r) 
     Next r 
    Loop 
    Permutations = perms 
End Function 

gibi test edilmiştir

Ayrıca 2 1 3 4 5 6 7 8 9 10 hemen penceresinde basılır. İlk versiyonumda bir vanilya varyantı kullanılmış ve n = 10 ile bellek yetersizliği hatasına neden oldu. perms'un tamsayıları (varyantlardan daha az bellek tüketen) içerecek şekilde yeniden boyutlandırıldığı ve şimdi 10 ile başa çıkabileceği şekilde yeniden düzenledim. Test kodunu çalıştırmak için makinemde yaklaşık 10 saniye gerekiyor.

Answer 2

For a = 1 To 10 
    For b = 1 To 10 
     If b <> a Then '<-- this check will make sure subsequent inner loops shouldn't bother but for their loops variables 
      For c = 1 To 10 
       If c <> b Then '<-- same comment as preceeding one 
        For d = 1 to 10 
         If d <> c then MsgBox (a & " " & b & " " & c & " " & d) '<-- last check for last two variables 
        Next d 
       End If 
      Next c 
     End If 
    Next b 
Next a 

aşağıdaki gibi basitçe doğru her bir iç döngünün başlamasından sonra bir çek ekleyebilir

Answer 3

Tüm bu değişkenleri diziye koymayı ve çoğaltma için diziyi kontrol etmeyi deneyin, eğer bulunamazsa, ileti kutusunu görüntüleyin. Böyle bir şey:

Sub dupfind() 
Dim ArrHelper(2) As Long 
Dim k As Long 
Dim j As Long 
Dim ans As Long 
Dim dupl As Boolean 
Dim ArrAnswers() As Long 

ans = 0 

For a = 1 To 10 
    ArrHelper(0) = a 
    For b = 2 To 10 
     ArrHelper(1) = b 
     For c = 1 To 10 
      ArrHelper(2) = c 
      dupl = False 
      For k = 0 To UBound(ArrHelper) - 1 
       For j = k + 1 To UBound(ArrHelper) 

        If ArrHelper(k) = ArrHelper(j) Then 
         dupl = True 
        End If 

       Next j 
      Next k 

       If dupl = False Then 
        ReDim Preserve ArrAnswers(3, ans) 
        ArrAnswers(0, ans) = a 
        ArrAnswers(1, ans) = b 
        ArrAnswers(2, ans) = c 
        ans = ans + 1 
       End If 
     Next c 
    Next b 
Next a 


End Sub 

saklamak permütasyon ilgili Düzenlemenizi Oku ve gelince kodunu biraz