kunde
Isaan Rules WFF CCC
If you walked away smiling-then for you the price was right
Keep Exceling
Suosikkibändit/artistit: Queen, Rammstein, genesis, Bruce Bringsteen, Kino, Mandref Mann Earth band Who
Lempikirjat: ohjelmointi...
Suosikkipalstat Suomi24 Keskusteluissa: EXCEL, Kivitalot, EPS
En pidä: pakkanen ja loskakelit
Ruoka & juoma: loimulohi ja valkkari
Linkit: http://www.kundepuu.com, Khorat
Koulutus: ---
Ammatti: Tiede/teknologia
Työskentelen: freelancer
Ase tai siviilipalvelus: yliluutnantti
Siviilisääty: Varattu
Lapset: ---
Hakusanat: Thaimaa, korat, Excel, VBA, ACAD, CNC, Polyurea, EPS, MgO elementti
Liittynyt sitten
Muokkaa profiilia7 aloitusta · 1377 kommenttia
- "Taulukossa on makro joka tuottaa räätälöityä tekstiä solun kommenttiin.
Deggaus osoittaa koodiriviin:
.Comment.Shape.TextFrame.AutoSize = True"
Ei tommosen perusteella voi mitään ohjeita antaa tai korjata koodia.
Mikä excel versio?
laita koodi kokonaisuudessaan niin sitten voi yrittää korjata... - Esim. A1:A6
3,4
1,5
47
25,6
7,5
102,5
soluun mihin haluat tuloksen kaava
=MontakoTämmöstä(A1:A6;"*,5*")
funktio palauttaa arvon 3
moduuliin...
Function MontakoTämmöstä(alue As Range, malli As String) As Integer
Dim solu As Range
MontakoTämmöstä = 0
For Each solu In alue
If solu Like malli Then MontakoTämmöstä = MontakoTämmöstä 1
Next solu
End Function - moduuliin...
Sub Sorttaa()
Dim Rng As Range
Dim Vika As Integer
Dim Solu As Range
Dim Numero As String
Dim Teksti As String
Dim a As Variant
Application.DisplayAlerts = False
On Error Resume Next
'Type:=8 sallii vain solualueen
Set Rng = Application.InputBox( _
Title:="Lajittelu", _
Prompt:="Valitse lajiteltava alue sarakkeesta", _
Type:=8)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub
Rng.NumberFormat = "@"
Sheets.Add.Name = "Huuhaa"
Rng.Copy Worksheets("Huuhaa").Range("A1")
'pilkotaan solu numero ja tekstiosaan
For Each Solu In Worksheets("Huuhaa").Range("A1").Resize(Rng.Count)
' numero-osa(toimii vain, jos numero-osa on alussa
Numero = Val(Solu)
Solu.Offset(0, 1) = Numero
' tekstiosa
Teksti = Application.WorksheetFunction.Replace(Solu, 1, Len(Numero), "@")
a = Split(Teksti, "@")
' lisätään esim. a-kirjain, jotta saadaan lajiteltua pelkän luvun sisältävät solut oikein
Solu.Offset(0, 2) = "a" & a(1)
Next
' lajitellaan numero-osan ja sitten kirjainten mukaan
Worksheets("Huuhaa").Columns("A:C").Select
ActiveWorkbook.Worksheets("Huuhaa").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Huuhaa").Sort.SortFields.Add2 Key:=Range("B1:B8") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Huuhaa").Sort.SortFields.Add2 Key:=Range("C1:C8") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Huuhaa").Sort
.SetRange Range("A1:C8")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'muuta taulukon nimi sopivaksi
Worksheets("Huuhaa").Range("A1:A" & Rng.Count).Copy Worksheets("Taul1").Range(Rng.Address)
Worksheets("Huuhaa").Delete
Application.DisplayAlerts = True
End Sub
Keep EXCELing
@Kunde - Taulukon tulostusasetuset voi kopioida helposti
Worksheets(2).PageSetup.PrintArea = Worksheets(1).PageSetup.PrintArea
Keep EXCELing
@Kunde - Helppoa kuin heinän teko..
Ainut helppo ja varma tapa tehdä datatyyppi muutokset . ;-)
Valitse solu/sarake/rivi , mihin haluat muutoksen.
Valitse menusta Data/Text to Columns
Klikkaa seuraavaa nappia 2 kertaa ja sitten vaihdat muotoiluksi Date ja Finish
Sitten muoilet solun/sarakkeen/rivin muotoiluksi haluamasi muotoilun...
Keep EXCELing
@Kunde - Helpoin ja ehkä fiksuin tapa on
lukea kaikki taulukoiden nimet esim. A -sarakkeeseen
B-sarakkeesen fontiksi Marlet ja kirjain a Ok merkiksi valintaan
valinta taulukon näytölle tehdään tuplaklikkaamalla B- sarakkeessa halutun taulukon kohdalla B-sarakkeessa ja piilotus vastaavasti tuplaklikkaamalla
Koodi esim. Worksheet_BeforeDoubleClick tapahtumaan ja tutkitaan sitten onko a -kirjain vaiko tyhäja sen mukaan näytetään/piilotetaan taulukko - fiksattu ja tehty VBA:lla...
https://www.dropbox.com/scl/fi/e4nrsv4qclimxcja36n8a/Q-testi.xlsm?dl=0&rlkey=tmaq5loqiy5n5gwma03b6gzgu
Keep EXCELing
@Kunde - nyt lukuja soluissa A1:A7
{=INDEX(A1:A7;MATCH(MIN(ABS(A1:A7-AVERAGE(A1:A7)));ABS(A1:A7-AVERAGE(A1:A7));0))}
kaava syötettävä matriisikaavana
Keep EXCELing
@Kunde - Sanotaanko melko peruskone käytössä.
Järjen käyttö on sallittua tässäkin kyssärissa ja eihän tuo lopputuloksen koodin suorituskaan kauaa kestä iman tulostusta (n. 5 s) ;-)
Tommosen 15! käsittelyä ei tartte tehdä (eikä pystykään) vaan pienillä variaatioilla aluksi, jotta näkee koodin toimivuuden ja sitten isonnetaan variaatioita jne. - aiemmin postasin....
Koodissani oli se 100000 rajoitus printtauksille(testi)...
Fiksasin nyt sitten siten , että tulostaa ekat 1 000 000 riviä B-P sarakkeisiin ja loput 401400 sarakkeisiin R-AF.
https://www.dropbox.com/scl/fi/gprp9qjrlo7hyg82zmmzx/Ryhmien-teko.xlsm?dl=0&rlkey=eo3c0jksplndr8z0p49k4o483 - tuo lopun pitäisi olla
ja viimeinen variaatio
('1', '14', '15'),('2, '12', '13')
....
('1', '14', '15'),('2, '12', '13'),('3', '10', '11')
('1', '14', '15'),('2, '12', '13'),('3', '10', '11'),('4 '8', '9')
('1', '14', '15'),('2, '12', '13'),('3', '10', '11'),('4 '8', '9'),('5', '6', '7') - Kun tutkailee kaikkia kombinaatioita 15!(1,30767E 12 kpl) !!!, niin huomataan, että riittää, kun kun käy läpi ensimmäisen ryhmän kaikki vaihtoehdot jotka alkaa numerolla 1
Olet ihan kuutamolla ja et ole ymmärtänyt kysymystä, etkä selitystäni.
Ja miten Python liittyy EXCEL VBA ohjelmointiin?
Antamassasi esimerkissä
('A', 'B', 'C')
('A', 'C', 'B')
('B', 'A', 'C')
('B', 'C', 'A')
('C', 'A', 'B')
('C', 'B', 'A')
riittää kun kun ottaa huomioon vaan ekan rvin, koska muuthan on aivan samoja vaan eri järjestyksessä.
('A', 'B', 'C') eli ohjelmassani se vastaa ('1', '2', '3')
vaihtoehtojahan on enemmän kuin tuo 6
eli malliksi muutama ekarivin variaatio
('1', '2', '3')
('1', '2', '4')
('1', '2', '5')
...
('1', '8', '15')
...
ja viimeinen variaatio
('1', '14', '15')
seuraavaksi siis 2 ryhmä (siis variaation eka rivi)
('1', '2', '3'),('3', '4', '5')
('1', '2', '4'),('3', '5', '6')
('1', '2', '5'),('3', '4', '6')
...
('1', '8', '15')('2', '3', '4')
...
ja viimeinen variaatio
('1', '14', '15'),('2, '13', '15')
....
('1', '14', '15'),('2, '12', '13'),('3', '10', '11')
('1', '14', '15'),('2, '12', '13'),('3', '10', '11'),('4 '8', '9')
('1', '14', '15'),('2, '13', '15'),('3', '10', '11'),('4 '8', '9'),('5', '6', '7')
Esitä nyt semmoinen koodi vaikka nyt sitten Pythonilla, joka tekee vastaavan tulostuksen variaatioista, sitähän se alkuperäinen kysyjä on vailla ,eikä mitään muuta.
Keep EXCELing
@Kunde - Sub HakeeKaikistaTaulukoista()
Dim ws As Worksheet
Dim Löydetty As Range
Dim Haku As String
Dim Tupla As Boolean
Dim kpl As Long
Dim i As Long
Dim C6Arvo As Variant
Dim Nimi As String
On Error Resume Next
'haettava tieto ( nyt Sheet1 taulukko, oletetaan aktiiviseksi, kuna makroa suoritetaan, muuta alempana nimi oikeaksi
Haku = Range("B3")
kpl = Worksheets.Count
For i = 1 To kpl
' muuta hakusolun taulukon nimi sopivaksi(ettei hae siitä...)
If Worksheets(i).Name <> "Sheet1" Then
With Worksheets(i).UsedRange
Set Löydetty = .Find(What:=Haku, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not Löydetty Is Nothing Then
If Tupla Then
C6Arvo = ""
Nimi = ""
GoTo loppu
End If
Tupla = True
C6Arvo = Worksheets(i).Range("C6")
Nimi = Worksheets(i).Name
End If
End With
End If
Next i
On Error GoTo 0
loppu:
'muuta taulukon nimi ja solut sopiviksi
Worksheets("Sheet1").Range("C6") = C6Arvo
Worksheets("Sheet1").Range("D6") = Nimi
End Sub
Keep EXCELing
@Kunde - 3exp13= 1 594 323 riviä
- Ihme sekoiluja...
Kyssärihän oli aivan selekeästi esitetty ja koodissani se tekee juuri niinkuin pitääkin
Koodissani oli se 100000 rajoitus printtauksille(testi)...
Fiksasin nyt sitten siten , että tulostaa ekat 1 000 000 riviä B-P sarakkeisiin ja loput 401400 sarakkeisiin R-AF.
https://www.dropbox.com/scl/fi/gprp9qjrlo7hyg82zmmzx/Ryhmien-teko.xlsm?dl=0&rlkey=eo3c0jksplndr8z0p49k4o483
Keep EXCELing
@Kunde - tota Excelin omaa natiivikieltä voi käyttää sitten suoraan excelin solukaavoissa
eli jos haluat tuotteen 8 ominaisuuden 3
soluun vaan kaava = tuote8(välilyönti tässä)ominaisuus3
Valitse "mun tietokanta" ja menusta FORMULAS/CREAT FROM SELECTION määrittele
TOP ROW ja LEFT COLUMN
tekstitiedosto muotoa( voit käyttää haluamaasi erotinta,muista fiksata myös koodissa)
tuote15;ominaisuus15;15
tuote14;ominaisuus14;14
tuote13;ominaisuus13;13
tuote12;ominaisuus12;12
tuote11;ominaisuus11;11
tuote10;ominaisuus10;10
tuote9;ominaisuus9;9
tuote8;ominaisuus8;8
tuote7;ominaisuus7;7
tuote6;ominaisuus6;6
tuote5;ominaisuus5;5
tuote4;ominaisuus4;4
tuote3;ominaisuus3;3
tuote2;ominaisuus2;2
tuote1;ominaisuus1;1
Sub TäytäMunTietokanta()
Dim Rivi As String
Dim iFile As Integer
Dim a
Dim Tuote As String
Dim Ominaisuus As String
'muuta taulukon nimi sopivaksi
Worksheets("Sheet1").Activate
iFile = FreeFile
'muuta polku ja tiedostonnimi sopivaksi
Open "C:\Kunde\koe.csv" For Input As #iFile
Do Until EOF(1)
Line Input #1, Rivi
' fiksaa tarvittaessa erotin
a = Split(Rivi, ";")
Tuote = a(0)
Ominaisuus = a(1)
Intersect(Range(Tuote), Range(Ominaisuus)) = a(2)
Loop
Close #iFile
End Sub - Testi
- hae esim. etsijasiirrä , niin monia esimerkkejä ja varmaan ihan suoraan kyssäriinkin löytyy mun tekemänä
jälkimmäiseen anonyymin kyssäriin koodi
ActiveSheet.Range("$A$1:$G$3258").AutoFilter Field:=1, Criteria1:="<>" & Range("Mycell") - Lisäsin koodiin vielä semmoisen, että jos A -sarakkeen luku on jo 0, niin ei voi lisätä X kirjainta- jos ei hyvälisäys, niin poistetaan sitten...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("C1:Z36"), Target) Is Nothing Then
If Target.Row Mod 2 = 1 Then
If Target = "X" Then
Target = ""
Range("A" & Target.Row) = Range("A" & Target.Row) 1
If Target.Column = 25 Then
Target.Offset(1, 0).Select
Else
Target.Offset(0, 1).Select
End If
Else
If Range("A" & Target.Row) <= 0 Then
Range("A" & Target.Row) = 0
If Target.Column = 25 Then
Target.Offset(1, 0).Select
Else
Target.Offset(0, 1).Select
End If
Else
Range("A" & Target.Row) = Range("A" & Target.Row) - 1
Target = "X"
If Target.Column = 25 Then
Target.Offset(1, 0).Select
Else
Target.Offset(0, 1).Select
End If
End If
End If
End If
End If
End Sub
Keep EXCELing
@Kunde - sori tämäkoodi piti postata...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("C1:Z36"), Target) Is Nothing Then
If Target = "X" Then
If Target.Column = 25 Then
Target.Offset(1, 0).Select
Else
Target.Offset(0, 1).Select
End If
Else
Target = "X"
If Range("A" & Target.Row) <= 0 Then
Range("A" & Target.Row) = 0
Else
Range("A" & Target.Row) = Range("A" & Target.Row) - 1
If Target.Column = 25 Then
Target.Offset(1, 0).Select
Else
Target.Offset(0, 1).Select
End If
End If
End If
End If
End Sub
Keep EXCELing
@Kunde