Permutacije!?

Pomoč pri delu z MS Excelom
Odgovori
alan07
Prispevkov: 22
Pridružen: To Apr 17, 2007 4:44 am

Permutacije!?

Odgovor Napisal/-a alan07 »

Iščem idejo, kako bi iz določene besede - " miza" program (Excel) izdelal vse možne zamenjave znakov- miza, miaz,maiz,mazi, ....- vseh 24.
Seveda, bi želel, da ne deluje samo za besedo miza in za dolžino 4.
Hvala Alan
admin
Site Admin
Prispevkov: 3687
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Permutacije!?

Odgovor Napisal/-a admin »

alan07 napisal/-a:Iščem idejo, kako bi iz določene besede - " miza" program (Excel) izdelal vse možne zamenjave znakov- miza, miaz,maiz,mazi, ....- vseh 24.
Nimate kaj veliko razmišljati... Potrebno je napisati VBA funkcijo, ki bo to naredila:

Koda: Izberi vse

Option Explicit

Sub Zazeni()
  Dim Vhod As String: Vhod = InputBox("Vhodna beseda:")
  Premutiraj "", Vhod, 1
End Sub

Sub Premutiraj(levo As String, desno As String, ByRef vrstica As Long)
  Dim i As Long, j As Long
  
  j = Len(desno)
  If j < 2 Then
    Cells(vrstica, 1) = levo & desno
    vrstica = vrstica + 1
  Else
    For i = 1 To j
      Premutiraj levo + Mid(desno, i, 1), Left(desno, i - 1) + Right(desno, j - i), vrstica
    Next
  End If
End Sub
Vendar pazite!!! Celic bo hitro zmanjkalo in tudi čas izvajanja bo eksponentno rastel! Pri 10 črkah potrebujete več kot 3 miljone vrstic (3,628,800)!
lp,
Matjaž Prtenjak
Administrator
alan07
Prispevkov: 22
Pridružen: To Apr 17, 2007 4:44 am

Hvala!

Odgovor Napisal/-a alan07 »

Vedno padem na izpitu rekurzije, fakulteto (funkcijo) pa poznam.
Matjaž, najlepša hvala! Alan
AndrejL
Prispevkov: 25
Pridružen: Po Nov 10, 2008 9:22 pm

Re: Permutacije!?

Odgovor Napisal/-a AndrejL »

si bom kar tole temo sposodil, ker se mi zdi, da moja težava spada sem.

iščem makro, ki bi (čim hitreje) našel vse binarne nize določene dožnine.

torej, če mu damo vhoden podatek 10, bo izračunal vseh 1024 binarnih nizov dolžine 10.

hvala za pomoč,

andrej
admin
Site Admin
Prispevkov: 3687
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Permutacije!?

Odgovor Napisal/-a admin »

Saj pri binarnih številih je pa algoritem zares trivialen, pač začnete s samimi ničlami in prištevate po 1 dokler ne pridete do samih enic.

Spodaj imate to zapisano v VBA kodi:

Koda: Izberi vse

'
'  www.matazev.net
'    junij 2010
'
Sub Izpisi(biti)
  Dim i
  For i = UBound(biti) To LBound(biti) Step -1
    Debug.Print biti(i);
  Next
  Debug.Print
End Sub

Sub IzpisiBinarnaStevila(stBitov As Integer)
  Dim biti() As Integer
  ReDim biti(stBitov - 1)
  
  Dim stevec As Integer
  For stevec = 0 To stBitov - 1
    biti(stevec) = 0
  Next
  
  Do
    Izpisi biti
    stevec = 0
    While (stevec < stBitov) And (biti(stevec) = 1)
      biti(stevec) = 0
      stevec = stevec + 1
      If (stevec = stBitov) Then Exit Do
    Wend
    biti(stevec) = 1
  Loop While True
End Sub
Za vaš primer pač poženite makro s parametrom 10:

Koda: Izberi vse

IzpisiBinarnaStevila 10
lp,
Matjaž Prtenjak
Administrator
AndrejL
Prispevkov: 25
Pridružen: Po Nov 10, 2008 9:22 pm

Re: Permutacije!?

Odgovor Napisal/-a AndrejL »

super, hvala
aamarko
Prispevkov: 4
Pridružen: Ne Dec 10, 2017 9:51 pm

Re: Permutacije!?

Odgovor Napisal/-a aamarko »

Ker sem popolnoma brez znanja VBA bi prosil za kodo, ki bi imela še en parameter in sicer število znakov v nizu. Se pravi en vnos za niz možnih znakov in dolžino permutiranega niza.
Npr:
Niz znakov: 12345
Dolžina niza: 2

Rezultati:
12
13
14
15
21
23
24
.
.
.
56

Hvala in lep pozdrav
admin
Site Admin
Prispevkov: 3687
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Permutacije!?

Odgovor Napisal/-a admin »

Pozdravljeni,

To o čemer govorite vi, niso permutacije, temveč varaicije. Iščete torej algoritem za generiranje variacij. Vprašanje, ki se mi zastavlja pa je, zakaj ga potrebujete? Ali je to domača naloga?
lp,
Matjaž Prtenjak
Administrator
aamarko
Prispevkov: 4
Pridružen: Ne Dec 10, 2017 9:51 pm

Re: Permutacije!?

Odgovor Napisal/-a aamarko »

admin napisal/-a:Pozdravljeni,

To o čemer govorite vi, niso permutacije, temveč varaicije. Iščete torej algoritem za generiranje variacij. Vprašanje, ki se mi zastavlja pa je, zakaj ga potrebujete? Ali je to domača naloga?
Že lep čas ne hodim v šolo. V službi delam neke analize in bi si rad sestavil določene variacije.
admin
Site Admin
Prispevkov: 3687
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Permutacije!?

Odgovor Napisal/-a admin »

Aha, to pa je malce več programske kode, vendar zdajle nimam časa. Bom prilepil tudi ustrezno funkcijo
lp,
Matjaž Prtenjak
Administrator
admin
Site Admin
Prispevkov: 3687
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Permutacije!?

Odgovor Napisal/-a admin »

Pozdravljeni,

Kot obljubljeno, vam pripenjam kodo za variacije.

Koda: Izberi vse

Option Explicit

Public znaki As String
Public znakiLen As Integer
Public varLen As Integer
Public idx() As Integer
Public maxIdx() As Integer

'Sub test()
'  Variiraj "1234567", 3
'End Sub

Sub Zazeni()
  Dim Vhod As String: Vhod = InputBox("Vhodna beseda:")
  Dim dolzina As String: dolzina = InputBox("Dolzina variacij:")
  
  Variiraj Vhod, CInt(dolzina)
End Sub


Sub Variiraj(beseda As String, dolzina As Integer)
  znaki = beseda
  znakiLen = Len(beseda)
  varLen = dolzina
  
  If (varLen >= znakiLen) Then
    MsgBox "Dolžina besede je prekratka!"
    Exit Sub
  End If
  
  ReDim idx(varLen)
  ReDim maxIdx(varLen)
  
  Dim i As Integer
  For i = 1 To varLen
    maxIdx(i) = znakiLen - varLen + i
  Next
  
  Columns("A:A").ClearContents
  init 1, 1
  
  Dim r As Integer: r = 1
  Do
    izpisi r
    r = r + 1
  Loop While naslednja
End Sub

Sub init(pos As Integer, start As Integer)
  Dim i As Integer
  For i = pos To varLen
    idx(i) = start + i - pos
  Next
End Sub

Sub izpisi(r As Integer)
  Dim rezultat As String: rezultat = ""
  
  Dim i
  For i = 1 To varLen
    rezultat = rezultat & Mid(znaki, idx(i), 1)
  Next
  
  Cells(r, 1) = rezultat
End Sub

Function naslednja() As Boolean
  naslednja = False
  
  Dim i As Integer
  For i = varLen To 1 Step -1
    If (idx(i) < maxIdx(i)) Then
      init i, idx(i) + 1
      naslednja = True
      Exit Function
    End If
  Next
End Function
lp,
Matjaž Prtenjak
Administrator
aamarko
Prispevkov: 4
Pridružen: Ne Dec 10, 2017 9:51 pm

Re: Permutacije!?

Odgovor Napisal/-a aamarko »

admin napisal/-a:Pozdravljeni,

Kot obljubljeno, vam pripenjam kodo za variacije.

Koda: Izberi vse

Option Explicit

Public znaki As String
Public znakiLen As Integer
Public varLen As Integer
Public idx() As Integer
Public maxIdx() As Integer

'Sub test()
'  Variiraj "1234567", 3
'End Sub

Sub Zazeni()
  Dim Vhod As String: Vhod = InputBox("Vhodna beseda:")
  Dim dolzina As String: dolzina = InputBox("Dolzina variacij:")
  
  Variiraj Vhod, CInt(dolzina)
End Sub


Sub Variiraj(beseda As String, dolzina As Integer)
  znaki = beseda
  znakiLen = Len(beseda)
  varLen = dolzina
  
  If (varLen >= znakiLen) Then
    MsgBox "Dolžina besede je prekratka!"
    Exit Sub
  End If
  
  ReDim idx(varLen)
  ReDim maxIdx(varLen)
  
  Dim i As Integer
  For i = 1 To varLen
    maxIdx(i) = znakiLen - varLen + i
  Next
  
  Columns("A:A").ClearContents
  init 1, 1
  
  Dim r As Integer: r = 1
  Do
    izpisi r
    r = r + 1
  Loop While naslednja
End Sub

Sub init(pos As Integer, start As Integer)
  Dim i As Integer
  For i = pos To varLen
    idx(i) = start + i - pos
  Next
End Sub

Sub izpisi(r As Integer)
  Dim rezultat As String: rezultat = ""
  
  Dim i
  For i = 1 To varLen
    rezultat = rezultat & Mid(znaki, idx(i), 1)
  Next
  
  Cells(r, 1) = rezultat
End Sub

Function naslednja() As Boolean
  naslednja = False
  
  Dim i As Integer
  For i = varLen To 1 Step -1
    If (idx(i) < maxIdx(i)) Then
      init i, idx(i) + 1
      naslednja = True
      Exit Function
    End If
  Next
End Function
Hvala za vaš trud in kodo, ki načeloma deluje ampak izpusti kar nekaj možnih rezultatov kot npr.:
Niz znakov: 12345
Dolžina niza: 2
Rezultat:
12
13
14
15
23
24
25
34
35
45
Manjkajo:
21, 31, 32, 41, 42, 43, 51. 52, 53, 54
admin
Site Admin
Prispevkov: 3687
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Permutacije!?

Odgovor Napisal/-a admin »

Ah, sem spregledal, da želite variacije s ponavljanjem.

Kodo sem popravil tako, da podate še zadni parameter (1 ali 0), če želite oz. ne želite ponavljanja:

Koda: Izberi vse

Option Explicit

Public znaki As String
Public znakiLen As Integer
Public varLen As Integer
Public sPonavljanjem As Boolean
Public idx() As Integer
Public maxIdx() As Integer

'Sub test()
'  Variiraj "1234567", 3
'End Sub

Sub Zazeni()
  Dim Vhod As String: Vhod = InputBox("Vhodna beseda:")
  Dim dolzina As String: dolzina = InputBox("Dolzina variacij:")
  Dim ponavljaj As String: ponavljaj = UCase(InputBox("Variacije s ponavljanjem?:"))
  
 
  Variiraj Vhod, CInt(dolzina), (ponavljaj = "DA") Or (ponavljaj = "1")
End Sub

Sub Variiraj(beseda As String, dolzina As Integer, ponavljaj As Boolean)
  znaki = beseda
  znakiLen = Len(beseda)
  varLen = dolzina
  sPonavljanjem = ponavljaj
 
  If (varLen >= znakiLen) Then
    MsgBox "Dolžina besede je prekratka!"
    Exit Sub
  End If
 
  ReDim idx(varLen)
  ReDim maxIdx(varLen)
 
  Dim i As Integer
  For i = 1 To varLen
    maxIdx(i) = znakiLen - varLen + i
  Next
 
  Columns("A:A").ClearContents
  init 1, 1
 
  Dim r As Long: r = 1
  Do
    izpisi r
  Loop While naslednja
End Sub

Sub Premutiraj(levo As String, desno As String, ByRef vrstica As Long)
  Dim i As Long, j As Long
 
  j = Len(desno)
  If j < 2 Then
    Cells(vrstica, 1) = levo & desno
    vrstica = vrstica + 1
  Else
    For i = 1 To j
      Premutiraj levo + Mid(desno, i, 1), Left(desno, i - 1) + Right(desno, j - i), vrstica
    Next
  End If
End Sub

Sub init(pos As Integer, start As Integer)
  Dim i As Integer
  For i = pos To varLen
    idx(i) = start + i - pos
  Next
End Sub

Sub izpisi(ByRef r As Long)
  Dim rezultat As String: rezultat = ""
 
  Dim i
  For i = 1 To varLen
    rezultat = rezultat & Mid(znaki, idx(i), 1)
  Next
 
  If (sPonavljanjem) Then
    Premutiraj "", rezultat, r
  Else
    Cells(r, 1) = rezultat
    r = r + 1
  End If
End Sub

Function naslednja() As Boolean
  naslednja = False
 
  Dim i As Integer
  For i = varLen To 1 Step -1
    If (idx(i) < maxIdx(i)) Then
      init i, idx(i) + 1
      naslednja = True
      Exit Function
    End If
  Next
End Function
lp,
Matjaž Prtenjak
Administrator
aamarko
Prispevkov: 4
Pridružen: Ne Dec 10, 2017 9:51 pm

Re: Permutacije!?

Odgovor Napisal/-a aamarko »

admin napisal/-a:Ah, sem spregledal, da želite variacije s ponavljanjem.

Kodo sem popravil tako, da podate še zadni parameter (1 ali 0), če želite oz. ne želite ponavljanja:

Koda: Izberi vse

Option Explicit

Public znaki As String
Public znakiLen As Integer
Public varLen As Integer
Public sPonavljanjem As Boolean
Public idx() As Integer
Public maxIdx() As Integer

'Sub test()
'  Variiraj "1234567", 3
'End Sub

Sub Zazeni()
  Dim Vhod As String: Vhod = InputBox("Vhodna beseda:")
  Dim dolzina As String: dolzina = InputBox("Dolzina variacij:")
  Dim ponavljaj As String: ponavljaj = UCase(InputBox("Variacije s ponavljanjem?:"))
  
 
  Variiraj Vhod, CInt(dolzina), (ponavljaj = "DA") Or (ponavljaj = "1")
End Sub

Sub Variiraj(beseda As String, dolzina As Integer, ponavljaj As Boolean)
  znaki = beseda
  znakiLen = Len(beseda)
  varLen = dolzina
  sPonavljanjem = ponavljaj
 
  If (varLen >= znakiLen) Then
    MsgBox "Dolžina besede je prekratka!"
    Exit Sub
  End If
 
  ReDim idx(varLen)
  ReDim maxIdx(varLen)
 
  Dim i As Integer
  For i = 1 To varLen
    maxIdx(i) = znakiLen - varLen + i
  Next
 
  Columns("A:A").ClearContents
  init 1, 1
 
  Dim r As Long: r = 1
  Do
    izpisi r
  Loop While naslednja
End Sub

Sub Premutiraj(levo As String, desno As String, ByRef vrstica As Long)
  Dim i As Long, j As Long
 
  j = Len(desno)
  If j < 2 Then
    Cells(vrstica, 1) = levo & desno
    vrstica = vrstica + 1
  Else
    For i = 1 To j
      Premutiraj levo + Mid(desno, i, 1), Left(desno, i - 1) + Right(desno, j - i), vrstica
    Next
  End If
End Sub

Sub init(pos As Integer, start As Integer)
  Dim i As Integer
  For i = pos To varLen
    idx(i) = start + i - pos
  Next
End Sub

Sub izpisi(ByRef r As Long)
  Dim rezultat As String: rezultat = ""
 
  Dim i
  For i = 1 To varLen
    rezultat = rezultat & Mid(znaki, idx(i), 1)
  Next
 
  If (sPonavljanjem) Then
    Premutiraj "", rezultat, r
  Else
    Cells(r, 1) = rezultat
    r = r + 1
  End If
End Sub

Function naslednja() As Boolean
  naslednja = False
 
  Dim i As Integer
  For i = varLen To 1 Step -1
    If (idx(i) < maxIdx(i)) Then
      init i, idx(i) + 1
      naslednja = True
      Exit Function
    End If
  Next
End Function
Deluje, najlepša hvala
Odgovori