Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 64098 Skopiuj do schowka Losowanie cyfry bez powtórzeń w pionie i poziomie.
Autor Wiadomość
zduno
świeżak


Posty: 2
Wysłany: 11-02-2019, 14:14   Losowanie cyfry bez powtórzeń w pionie i poziomie.

Witam,
Szukam sposobu aby wypełnić komórki cyfrą od 0 do 9, w formie tabeli.

1 7 3 9
2 8 4 0
3 9 5 1
4 0 6 2
5 1 7 3
6 2 8 4

Chciałbym żeby cyfra nie powtarzała się w pionie i poziomie.
Muszę tak wypełnić 600 takich tabel 4X6.
ID posta: 362359 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 242 razy
Posty: 1325
Wysłany: 11-02-2019, 16:21   

Witamy na Forum.

Masz na razie bez kontroli powtórzeń.
Kod:
Option Explicit

Private Sub CommandButton1_Click()
Dim losowana As Integer, i As Integer, j As Integer

Randomize

For i = 1 To 6
    For j = 1 To 4
        Cells(i, j).Value = Int(10 * Rnd)
    Next j
Next i
       
End Sub
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
  
ID posta: 362364 Skopiuj do schowka
 
 
BrunO 
ExcelSpec



Pomógł: 119 razy
Posty: 513
Wysłany: 11-02-2019, 18:56   

Bez powtórzeń to by każdy chciał :P

Kod:
Option Explicit
Option Base 1

Private r As Integer
Private c As Integer
Private nr As Integer
Private arr(4, 10) As Integer

Sub losuj()

Dim x As Long
odNowa:

For c = 1 To 4
    For r = 1 To 10
    x = 0
losowanie:
        nr = Round(Rnd * 9, 0)
       
        If ok Then
            arr(c, r) = nr
            Debug.Print c & "," & r & ": "; nr
        Else
            x = x + 1
            If x > 100 Then
                GoTo odNowa
            End If
           
            GoTo losowanie
        End If
   
    Next r
Next c


For c = 1 To 4
    For r = 1 To 10
            Cells(r, c).Value = arr(c, r)
    Next r
Next c


End Sub

Function ok() As Boolean
Dim i As Integer

'kolumna
For i = 1 To r - 1
    If arr(c, i) = nr Then
        ok = False
        Exit Function
    End If
Next i

'wiersz
For i = 1 To c - 1
    If arr(i, r) = nr Then
        ok = False
        Exit Function
    End If
Next i

ok = True
End Function

Nie jestem zbyt dumny z wykorzystania zmiennej x i flagi odNowa - takie na kolanie to napisane, ale jakoś musiałem się zabezpieczyć przed przypadkami, gdy jedyne dostępne w kolumnie liczby są już zajęte w wierszu.

Z tym, że to makro generuje jeden zestaw. A co z pozostałymi 599?

Gdzie chcesz to zapisywać? Każdy w osobnym arkuszu? Jeden pod drugim? 10 x 60?
Niby wystarczy to odpowiednio zapętlić, ale...

No i pozostaje kwestia niepowtarzalności tabel. Można by pomyśleć o mechanizmie, który zrzucałby do stringa cały zestaw i sprawdzał, czy taki sam ciąg już nie wystąpił.

losowanie.xlsm
Pobierz Plik ściągnięto 2 raz(y) 16.77 KB

  
ID posta: 362371 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 242 razy
Posty: 1325
Wysłany: 11-02-2019, 21:03   

Cytat:
Nie jestem zbyt dumny z wykorzystania zmiennej x i flagi odNowa
No to bez etykiety:

Kod:
Option Explicit

Private Sub CommandButton1_Click()
Dim wylosowana As Integer, i As Integer, j As Integer
Dim ile1 As Integer, ile2 As Integer

Randomize

ile1 = 2
ile2 = 2

For i = 1 To 6
    For j = 1 To 4
        Do While ile1 + ile2 > 2
            Cells(i, j).Value = Int(10 * Rnd)
            wylosowana = Cells(i, j).Value
            ile1 = WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, 4)), wylosowana)
            ile2 = WorksheetFunction.CountIf(Range(Cells(1, j), Cells(6, j)), wylosowana)
        Loop
        ile1 = 2
        ile2 = 2
    Next j
Next i
       
End Sub

Zostają pozostałe pytania. Autor?

@BrunO:
Cytat:
tabel 4X6


Zeszyt111111.xlsm
Pobierz Plik ściągnięto 2 raz(y) 19.12 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
  
ID posta: 362381 Skopiuj do schowka
 
 
BrunO 
ExcelSpec



Pomógł: 119 razy
Posty: 513
Wysłany: 11-02-2019, 21:40   

umiejead napisał/a:
Cytat:

@BrunO:
Cytat:
tabel 4X6


Oż, ale wtopa.
Czyli wszędzie zamiast
Kod:
For r = 1 To 10

powinno być
Kod:
For r = 1 To 6

co przy okazji wyeliminuje brak możliwości dopasowania ostatnich liczb w kolumnach, bo zawsze coś do wyboru zostanie... W sumie można więc poprzestać na:

Kod:
Option Explicit
Option Base 1

Private r As Integer
Private c As Integer
Private nr As Integer
Private arr(4, 10) As Integer

Sub losuj()

For c = 1 To 4
    For r = 1 To 6
losowanie:
        nr = Round(Rnd * 9, 0)
       
        If ok Then
            arr(c, r) = nr
            Debug.Print c & "," & r & ": "; nr
        Else
            GoTo losowanie
        End If
   
    Next r
Next c


For c = 1 To 4
    For r = 1 To 6
            Cells(r, c).Value = arr(c, r)
    Next r
Next c

End Sub

Function ok() As Boolean
Dim i As Integer

'kolumna
For i = 1 To r - 1
    If arr(c, i) = nr Then
        ok = False
        Exit Function
    End If
Next i

'wiersz
For i = 1 To c - 1
    If arr(i, r) = nr Then
        ok = False
        Exit Function
    End If
Next i

ok = True
End Function
  
ID posta: 362384 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 242 razy
Posty: 1325
Wysłany: 11-02-2019, 21:45   

A deklaracja tablicy? :devil
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 362385 Skopiuj do schowka
 
 
BrunO 
ExcelSpec



Pomógł: 119 razy
Posty: 513
Wysłany: 11-02-2019, 23:04   

Kopiesz leżącego :-/
Oczywiście celowo zostawiłem w niej miejsce, tak na wszelki wypadek :tease:
ID posta: 362389 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 176 razy
Posty: 788
Wysłany: 11-02-2019, 23:13   

zduno napisał/a:
1 7 3 9
2 8 4 0
3 9 5 1
4 0 6 2
5 1 7 3
6 2 8 4

...wypełnić 600 takich tabel 4X6.

umiejead napisał/a:
@BrunO: Cytat: tabel 4X6

BrunO napisał/a:
umiejead napisał/a: Cytat:

@BrunO: Cytat: tabel 4X6

Panowie/Państwo, to nie jest 4x6 ... tylko 6x4 ... :->

... czyżby jakaś kumulacja ... ? :->
  
ID posta: 362391 Skopiuj do schowka
 
 
BrunO 
ExcelSpec



Pomógł: 119 razy
Posty: 513
Wysłany: 11-02-2019, 23:55   

ąćęłńóś, oj, mocno dyskusyjne twierdzenie. W Range najpierw podajemy kolumnę, potem wiersze, ale już w Cell najpierw wiersz potem kolumnę. Więc nawet w micro$ofcie jednej normy nie wypracowali.
W tablicach też można spotkać zarówno nazywanie pierwszego wymiaru wierszem jak i kolumną.
Ktoś dawno dawno temu mnie uczył, że mierząc otwór najpierw zawsze podaje się jego szerokość, potem wysokość...

Myślę, że najważniejsze, żeby w efekcie końcowym było tyle wierszy i kolumn ile zduno "narysował"
ID posta: 362394 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 242 razy
Posty: 1325
Wysłany: 12-02-2019, 01:07   

W/g pomysłu BrunO: generowanie 600 losowań z zapisywaniem stringów i kontrolą duplikatów.
Kod:
Option Explicit

Private Sub CommandButton1_Click()
Dim wylosowana As Integer, i As Integer, j As Integer
Dim ile1 As Integer, ile2 As Integer, los As String, l As Integer
Dim dic As New Scripting.Dictionary

Randomize

ile1 = 2
ile2 = 2
l = 0
los = ""

Do Until l = 600

laPocz:
For i = 1 To 6
    For j = 1 To 4
        Do While ile1 + ile2 > 2
            Cells(i, j).Value = Int(10 * Rnd)
            wylosowana = Cells(i, j).Value
            ile1 = WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, 4)), wylosowana)
            ile2 = WorksheetFunction.CountIf(Range(Cells(1, j), Cells(6, j)), wylosowana)
        Loop
        ile1 = 2
        ile2 = 2
        los = los + CStr(wylosowana)
    Next j
Next i

On Error GoTo laPocz
dic.Add los, 1
l = l + 1
Cells(l + 10, 5).Value = los
los = ""
Loop

Cells(7, 12).Value = "Czas: " & Format(Now() - t, "nn:ss") & " sek."

End Sub

Odświeżanie celowo niewyłączone bo fajnie skaczą cyferki :mrgreen: .

Zeszyt111111.xlsm
Pobierz Plik ściągnięto 2 raz(y) 35.44 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
Ostatnio zmieniony przez umiejead 12-02-2019, 02:04, w całości zmieniany 1 raz  
ID posta: 362401 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 176 razy
Posty: 788
Wysłany: 12-02-2019, 01:58   

BrunO napisał/a:
oj, mocno dyskusyjne twierdzenie

... :-> ... a w arkuszu po lewej i w dół, to co najpierw masz ... kolumny czy wiersze ... :-> ?

Poza tym nie pisałem o wierszach i kolumnach tylko o wymiarowaniu.
Taki układ danych, to najzwyklejsza w świecie macierz, a tu układ i nazewnictwo są ściśle określone ... :-> ... jakby kto tam nie kombinował, czy szklanka do połowy pełna, czy w połowie pusta ... :-> ... o wymiarowaniu tablic w vba nie wspominając, gdzie zapis (1 To 4, 1 To 6) też jest jednoznaczny i niejednakowy z (1 To 6, 1 To 4) ... :->
ID posta: 362406 Skopiuj do schowka
 
 
zduno
świeżak


Posty: 2
Wysłany: 12-02-2019, 08:21   

Dziękuje za taki odzew bardzo mi pomogliście.
ID posta: 362414 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe