..|| Blog || Produkti/Storitve || MExcel || MDodatki || 300 nasvetov ||..

Permutacije!?

Pomoč pri delu z MS Excelom

Permutacije!?

OdgovorNapisal/-a alan07 » Če mar 11, 2010 8:41 pm

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
alan07
 
Prispevkov: 22
Pridružen: To apr 17, 2007 4:44 am



Matjazev.NET
 

Re: Permutacije!?

OdgovorNapisal/-a admin » Če mar 11, 2010 9:13 pm

alan07 je 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
admin
Site Admin
 
Prispevkov: 3529
Pridružen: Sr jul 20, 2005 10:06 pm

Hvala!

OdgovorNapisal/-a alan07 » Po mar 15, 2010 11:00 am

Vedno padem na izpitu rekurzije, fakulteto (funkcijo) pa poznam.
Matjaž, najlepša hvala! Alan
alan07
 
Prispevkov: 22
Pridružen: To apr 17, 2007 4:44 am

Re: Permutacije!?

OdgovorNapisal/-a AndrejL » Sr jun 09, 2010 3:54 pm

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
AndrejL
 
Prispevkov: 25
Pridružen: Po nov 10, 2008 9:22 pm

Re: Permutacije!?

OdgovorNapisal/-a admin » Sr jun 09, 2010 9:06 pm

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
admin
Site Admin
 
Prispevkov: 3529
Pridružen: Sr jul 20, 2005 10:06 pm

Re: Permutacije!?

OdgovorNapisal/-a AndrejL » Sr jun 09, 2010 9:47 pm

super, hvala
AndrejL
 
Prispevkov: 25
Pridružen: Po nov 10, 2008 9:22 pm

Re: Permutacije!?

OdgovorNapisal/-a aamarko » Po dec 11, 2017 6:18 pm

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
aamarko
 
Prispevkov: 4
Pridružen: Ne dec 10, 2017 9:51 pm

Re: Permutacije!?

OdgovorNapisal/-a admin » Po dec 11, 2017 8:58 pm

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
admin
Site Admin
 
Prispevkov: 3529
Pridružen: Sr jul 20, 2005 10:06 pm

Re: Permutacije!?

OdgovorNapisal/-a aamarko » To dec 12, 2017 11:17 am

admin je 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.
aamarko
 
Prispevkov: 4
Pridružen: Ne dec 10, 2017 9:51 pm

Re: Permutacije!?

OdgovorNapisal/-a admin » To dec 12, 2017 12:57 pm

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: 3529
Pridružen: Sr jul 20, 2005 10:06 pm

Re: Permutacije!?

OdgovorNapisal/-a admin » Sr dec 13, 2017 10:19 am

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
admin
Site Admin
 
Prispevkov: 3529
Pridružen: Sr jul 20, 2005 10:06 pm

Re: Permutacije!?

OdgovorNapisal/-a aamarko » Sr dec 13, 2017 4:14 pm

admin je 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
aamarko
 
Prispevkov: 4
Pridružen: Ne dec 10, 2017 9:51 pm

Re: Permutacije!?

OdgovorNapisal/-a admin » Sr dec 13, 2017 10:13 pm

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
admin
Site Admin
 
Prispevkov: 3529
Pridružen: Sr jul 20, 2005 10:06 pm

Re: Permutacije!?

OdgovorNapisal/-a aamarko » Če dec 14, 2017 8:43 am

admin je 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
aamarko
 
Prispevkov: 4
Pridružen: Ne dec 10, 2017 9:51 pm


Vrni se na Excel

Kdo je prisoten

Po forumu brska: 0 registriranih uporabnikov in 2 gostov

cron