lukuparien haku

tiedot on laskentataulukossa ja jokainen luku on omassa solussa, luvut on kokonaislukuja 1:stä alkaen. tieto voisi tulostua omaan taulukkoon taikka erilliseen ikkunaan kumpiko on helpompi toteuttaa. lukupareista ei välttämättä tarvitse löytää kuin esim. 5-10 useimmiten esiintyvää paria

rthklrt kirjoitti:

tiedot on laskentataulukossa ja jokainen luku on omassa solussa, luvut on kokonaislukuja 1:stä alkaen. tieto voisi tulostua omaan taulukkoon taikka erilliseen ikkunaan kumpiko on helpompi toteuttaa. lukupareista ei välttämättä tarvitse löytää kuin esim. 5-10 useimmiten esiintyvää paria

Lue lisää

Tässä esimerkissä toimitaan samassa taulussa (Taul1). Haettavat tiedot on A-sarakkeessa ja lukujen esiintymiskerrat tulevat C-D sarakkeisiin järjestettynä esiintymiskertojen mukaan.
Kopioi koodi johonkin makromoduuliin esim. Module1. Huomaa, että taulun sarakkeiden C-D kaikki tiedot poistetaan ensiksi.

Sub LaskeEsiintymisKerrat()
Application.ScreenUpdating = False
Sheets("Taul1").Activate
Columns("C:D").ClearContents
Set rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C1"), Unique:=True
Lr = Range("C2").End(xlDown).Row
Range("C1:C" & Lr).Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess

For Each c In Range("C2:C" & Lr)
Range("A1").AutoFilter Field:=1, Criteria1:=c.Value

Kpl = Application.Subtotal(3, Range("A2:A65536"))
Range("D" & c.Row) = Kpl
Next

Range("D1") = "Kerrat"
ActiveSheet.AutoFilterMode = False
Range("C1:D" & Lr).Sort Key1:=Range("D2"), Order1:=xlDescending, Key2:=Range("C2") _
, Order2:=xlDescending, Header:=xlGuess

End Sub

rpo kirjoitti:

Tässä esimerkissä toimitaan samassa taulussa (Taul1). Haettavat tiedot on A-sarakkeessa ja lukujen esiintymiskerrat tulevat C-D sarakkeisiin järjestettynä esiintymiskertojen mukaan.
Kopioi koodi johonkin makromoduuliin esim. Module1. Huomaa, että taulun sarakkeiden C-D kaikki tiedot poistetaan ensiksi.

Sub LaskeEsiintymisKerrat()
Application.ScreenUpdating = False
Sheets("Taul1").Activate
Columns("C:D").ClearContents
Set rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C1"), Unique:=True
Lr = Range("C2").End(xlDown).Row
Range("C1:C" & Lr).Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess

For Each c In Range("C2:C" & Lr)
Range("A1").AutoFilter Field:=1, Criteria1:=c.Value

Kpl = Application.Subtotal(3, Range("A2:A65536"))
Range("D" & c.Row) = Kpl
Next

Range("D1") = "Kerrat"
ActiveSheet.AutoFilterMode = False
Range("C1:D" & Lr).Sort Key1:=Range("D2"), Order1:=xlDescending, Key2:=Range("C2") _
, Order2:=xlDescending, Header:=xlGuess

End Sub

Lue lisää

tuota joo, tuo edellinen koodinpätkä ei ihan vastannut sitä jota hain. jos koitan selvittää lisää mitä ajan takaa. taulukon riveillä on esim. lukuja seuraavasti:
2 15 20 46 55 74 78 80 81 93 150 200
1 16 18 44 66 77 82 90 93 104 167 199
2 4 12 20 55 44 69 75 80 81 99 167
1 2 13 20 54 61 69 77 84 110 143 156

eli tuosta noin puolihuolimattomasti laskien useimmiten esiintyvät parit 2 ja 20 esiintyy 3 kertaa, 20 ja 80 2 kertaa. eli haussa olisi kaksi lukua jotka useimmiten esiintyvät yhdessä kun tarkastellaan taulukkoa jossa nuo luvut ovat riveillä

ervhevh kirjoitti:

tuota joo, tuo edellinen koodinpätkä ei ihan vastannut sitä jota hain. jos koitan selvittää lisää mitä ajan takaa. taulukon riveillä on esim. lukuja seuraavasti:
2 15 20 46 55 74 78 80 81 93 150 200
1 16 18 44 66 77 82 90 93 104 167 199
2 4 12 20 55 44 69 75 80 81 99 167
1 2 13 20 54 61 69 77 84 110 143 156

eli tuosta noin puolihuolimattomasti laskien useimmiten esiintyvät parit 2 ja 20 esiintyy 3 kertaa, 20 ja 80 2 kertaa. eli haussa olisi kaksi lukua jotka useimmiten esiintyvät yhdessä kun tarkastellaan taulukkoa jossa nuo luvut ovat riveillä

Lue lisää

jokainen tieto pitää lypsää ? Mistä ihmeestä me voimme tietää mitä sinä oikein haluat ?
Miten esim. 2 & 20 liittyvät yhteen tai miten 20 & 80 ????
Sinä et kerro mitään ja odotat silti vastauksia...

ervhevh kirjoitti:

tuota joo, tuo edellinen koodinpätkä ei ihan vastannut sitä jota hain. jos koitan selvittää lisää mitä ajan takaa. taulukon riveillä on esim. lukuja seuraavasti:
2 15 20 46 55 74 78 80 81 93 150 200
1 16 18 44 66 77 82 90 93 104 167 199
2 4 12 20 55 44 69 75 80 81 99 167
1 2 13 20 54 61 69 77 84 110 143 156

eli tuosta noin puolihuolimattomasti laskien useimmiten esiintyvät parit 2 ja 20 esiintyy 3 kertaa, 20 ja 80 2 kertaa. eli haussa olisi kaksi lukua jotka useimmiten esiintyvät yhdessä kun tarkastellaan taulukkoa jossa nuo luvut ovat riveillä

Lue lisää

collectionilla menee aika kivasti...
muokkaa taulukot ja muut itsellesi sopivaksi

HAUSKAA JOULUA JA HYVÄÄ UUTTA VUOTTA PALSTALAISILLE!!!
Keep Excelling @Kunde

Sub Haeparit()

Dim Alue As Variant
Dim Rivit As Long
Dim Sarakkeet As Long
Dim Parikokoelma As New Collection
Dim Jäsen As Long
Dim Kuvaus As String
Dim Määrät(10000, 4) As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim vika As Long
On Error Resume Next

Sheets("Taul1").Select ' muuta taulukon nimi
vika = Range("A65536").End(xlUp).Row
Alue = Range("A1:L" & vika) ' muuta alue

Rivit = UBound(Alue, 1)
Sarakkeet = UBound(Alue, 2)
For i = 1 To Rivit
For j = 1 To Sarakkeet - 1
For k = j 1 To Sarakkeet
If Alue(i, j) < Alue(i, k) Then
Kuvaus = Alue(i, j) & "." & Alue(i, k)
Else
Kuvaus = Alue(i, k) & "." & Alue(i, j)
End If
Parikokoelma.Add Parikokoelma.Count 1, Kuvaus
Jäsen = Parikokoelma(Kuvaus)
If Määrät(Jäsen, 0) = "" Then
Määrät(Jäsen, 0) = Kuvaus
Määrät(Jäsen, 1) = Alue(i, j)
Määrät(Jäsen, 2) = Alue(i, k)
End If
If Määrät(Jäsen, 3) = "" Then
Määrät(Jäsen, 3) = "1"
Else
Määrät(Jäsen, 3) = CStr(CInt(Määrät(Jäsen, 3)) 1)
End If
Next k
Next j
Next i
Sheets("Taul2").Select 'muuta taulukon nimi
Cells.Clear
Cells(1, 1).Resize(Parikokoelma.Count, 4) = Määrät
Range("A1") = "Numero1.Numero2"
Range("B1") = "Numero1"
Range("C1") = "Numero2"
Range("D1") = "Esiintymät"
Range("A1:D1").Font.Bold = True
Columns("A:D").Sort Key1:=Range("D2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Columns("A:D").EntireColumn.AutoFit
Columns("A:A").Delete 'poistaa Numero1.Numero2 sarakkeen
End Sub

kunde kirjoitti:

collectionilla menee aika kivasti...
muokkaa taulukot ja muut itsellesi sopivaksi

HAUSKAA JOULUA JA HYVÄÄ UUTTA VUOTTA PALSTALAISILLE!!!
Keep Excelling @Kunde

Sub Haeparit()

Dim Alue As Variant
Dim Rivit As Long
Dim Sarakkeet As Long
Dim Parikokoelma As New Collection
Dim Jäsen As Long
Dim Kuvaus As String
Dim Määrät(10000, 4) As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim vika As Long
On Error Resume Next

Sheets("Taul1").Select ' muuta taulukon nimi
vika = Range("A65536").End(xlUp).Row
Alue = Range("A1:L" & vika) ' muuta alue

Rivit = UBound(Alue, 1)
Sarakkeet = UBound(Alue, 2)
For i = 1 To Rivit
For j = 1 To Sarakkeet - 1
For k = j 1 To Sarakkeet
If Alue(i, j) < Alue(i, k) Then
Kuvaus = Alue(i, j) & "." & Alue(i, k)
Else
Kuvaus = Alue(i, k) & "." & Alue(i, j)
End If
Parikokoelma.Add Parikokoelma.Count 1, Kuvaus
Jäsen = Parikokoelma(Kuvaus)
If Määrät(Jäsen, 0) = "" Then
Määrät(Jäsen, 0) = Kuvaus
Määrät(Jäsen, 1) = Alue(i, j)
Määrät(Jäsen, 2) = Alue(i, k)
End If
If Määrät(Jäsen, 3) = "" Then
Määrät(Jäsen, 3) = "1"
Else
Määrät(Jäsen, 3) = CStr(CInt(Määrät(Jäsen, 3)) 1)
End If
Next k
Next j
Next i
Sheets("Taul2").Select 'muuta taulukon nimi
Cells.Clear
Cells(1, 1).Resize(Parikokoelma.Count, 4) = Määrät
Range("A1") = "Numero1.Numero2"
Range("B1") = "Numero1"
Range("C1") = "Numero2"
Range("D1") = "Esiintymät"
Range("A1:D1").Font.Bold = True
Columns("A:D").Sort Key1:=Range("D2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Columns("A:D").EntireColumn.AutoFit
Columns("A:A").Delete 'poistaa Numero1.Numero2 sarakkeen
End Sub

Lue lisää

ne löytyi mukavasti, kiitoksia