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
- foorumi on hävittänyt koodista erisuuret merkit kummastakin koodista
eli rivit pitäisi olla tällaisia
Loop While Not Solu Is Nothing And Solu.Address (tähäni merkit) Ekaosoite
tähän merkit kohtaan ilman sulkuja siis merkit < ja >
Keep EXCEling
@Kunde - ei oo kerinnyt tekemään....
vkl tsekkaan
Keeo EXCLing
@Kunde - Mieti vaan rauhassa
Ei tossa koodissa toki paljoa "muistettavaa" ole
Keep EXCELing
@Kunde - losää rivi koodiin
Private Sub Worksheet_SelectionChange(ByVal Target As Range) proseduurissa
...
Target.Offset(0, 1) = ""
Target.Offset(0, 2) = ""
Target.Offset(0, 2).Comment.Delete
....
Keep EXCEing
@Kunde - https://www.dropbox.com/s/sote12qsp1615yj/Kelpoisuusehto oikea valikko.xlsm?dl=0
Keep EXCELing
@Kunde - tossa malli, jota helppo fiksata lisää
https://www.dropbox.com/s/82z2i3lt80iqamm/Kelpoisuusehto oikea valikko.xlsm?dl=0
Keep EXCELing
@Kunde - Noi lisätiedothan vosii laittaa vaikka siihen kalorisolun kommenttiin...
Vähän aikaa sitten postasin tänne koodin kommenttiin kirjoittamisesta ja se pitää lisätä tohon Worksheet_Change tapahtumaan
Set Löydetty = EtsiJaSiirrä(Target.Offset(0, -1))
Target.Offset(0, 1) = Round(Target * Löydetty / 100, 0)
.....
tähän kommnetti koodi
......
lisäät vaan Taul2 kalorisolujen jatkeeksi nuo tiedot ja sieltä siirrät offsetilla kommenttiin - Hyvää kandee aina odotella... ;-)
Oli hiukan kiireitä, mutta tossa nyt aakkostettu ruokalista menu. Helppohan se olisi ollut jakaa osiin, mutta vaikea sitten tietää missä osassa annos olisi...
Useammalle "sarakkeelle " ei voi tehdä. Toki lomake olisi ollut vaihtoehtona, mutta mielestäni tämä kätevin tapa?
Nyt annokset lajiteltu alkukirjainten mukaan ryhmiin
Meinasin tehdä koko jututn ribboniin, mutta se liian vaikeata kokemattoman fiksailla sitä...
Päädyin siis aakkostavaan menuun ja fiksaus helppoa siihen keltaiseeen maalattuun alueeseen Taul2:ssa. Sarakkeessa voi olla enemmänkin rivejä ja jos ei ryhmät riitä ota uusi sarake käyttöön ja lisää koodissa sarake
https://www.dropbox.com/s/yn4q1sj3bc8ovdv/Kelpoisuusehto oikea valikko.xlsm?dl=0
Keep EXCELing
@Kunde - Huomenna parit eri vaihtoehdot asian tiimoilta
- Hyvä havainto!
Olen reilut 20 v Exceliä ohjelmoinut ja en ole ikinä törmännyt tohon ja en ole myöskään keskustelupalstoilta havainnut tuota ihmeteltävän.
Asiahan on tosin ihan looginen, mutta eipä ole ole tullut mieleenkään,että näin voi käydä...
tossa fiksattuna nyt
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
'solualue mihin haluat kelpoisuusehdon, nyt
' "B3:B53", "E3:E53", "H3:H53", "K3:K53", "N3:N53"
'lisää Rangeja union funktion sisään pilkulla eroteltuna
If Not Intersect(Target, Union(Range("B3:B53"), Range("E3:E53"), Range("H3:H53"), Range("K3:K53"), Range("N3:N53"))) Is Nothing Then
' jos solu ei ole tyhjä, niin tyhjentää ja B,C ja D ja vastaavat solut muissa ryhmissä
'varmistetaan, että vain 1 solu on valittuna...
If Selection.Count = 1 Then
If Not Target = "" Then
Target = ""
Target.Offset(0, 1) = ""
Target.Offset(0, 2) = ""
Target.Offset(0, 1).Select
Target.Select
TeeValikko
Application.CommandBars("Cell").ShowPopup
Target.Offset(0, 1).Select
' jos solu tyhjä
Else
TeeValikko
Application.CommandBars("Cell").ShowPopup
Target.Offset(0, 1).Select
End If
End If
End If
Resetoi
Application.EnableEvents = True
End Sub
Keep EXCELing
@Kunde
. - Pikku viilaus korjaa juurikin tuon edellisen postauksesi kummitusongelman . ..
Keep EXCEling
@Kunde - pikku viilaus vielä lisätty...
https://www.dropbox.com/s/zq7bqz1o7upbxdt/Kelpoisuusehto oikea valikko.xlsm?dl=0
Keep EXCELing
@Kunde - https://www.dropbox.com/s/2ufatfv8c36uy3r/Kelpoisuusehto oikea valikko.xlsm?dl=0
Keep EXCELing
@Kunde - jotain varmaan olet tehnyt väärin...
testaa tolla ja lisäsisn siihen grammat ja kokonaiskalorit kanssa
https://www.dropbox.com/s/qxy285hwbikwvy0/Kelpoisuusehto oikea valikko.xlsm?dl=0
Keep EXCELing
@Kunde - "Lisäsin taulukkoon alueelle A30-A70 nimilistan ja tein soluun E6 kelpoisuusehdon em. nimilistasta. Avaan hiirellä nuolenkärkivalikon auki ja siellä lista näkyy."
koodiohjessani lukee...
"tavalliseen moduuliin...
TeeValikko ()
tekee uuden hiiren oikean valikon
voit lisätä uusi kelpoisuusehtoja B sarakkeeseen nyt B39 alkaen."
eli ei voi näkyä mitään koska listasi A30-A70 eikä B39:Bxxx
Ja toisekseen ei tarvitse lisätä mitään kelpoisuusehtoja manuaalisesti , koska lista tehdään lennossa hiiren oikeaan valikoon. Muuta listan paikkaa koodissa eli nyt sun testitapauksessa siinä pitäisi olla
'voi lisätä uusia kelpoisussehtoja ja koodi päivyttyy automaatisesti
Vika = Range("A65536").End(xlUp).Row
For Each Solu In Range("A30:A" & Vika)
Keep EXCELing
@Kunde - Tuostahan on helppo fiksata mitä tahansa... ;-)
- nyt lisää kaavasolun 10 viimeisintä arvoa kommenttiin ja poistaa aina vanhimman sen jälkeen
jos tarttee fiksata niin kerro
ko taulukon moduuliin...
Public Vanha As String
Dim b
Private Sub Worksheet_Change(ByVal Target As Range)
'solu minkä arvoa muutetaan
If Target.Address = Range("B1").Address Then
'kaavan tulos solu
With Range("C1")
If .Comment Is Nothing And .Value <> "" Then
.AddComment.Text ""
.Comment.Text "Kaavan tulokset:" & vbNewLine & .Value
Vanha = .Value
Else
b = Split(.Comment.Text, vbNewLine)
If UBound(b) < 10 Then
.Comment.Text "Kaavan tulokset:" & vbNewLine & .Value & vbNewLine & Vanha
Vanha = .Value & vbNewLine & Vanha
Else
Vanha = .Value & vbNewLine & _
b(1) & vbNewLine & _
b(2) & vbNewLine & _
b(3) & vbNewLine & _
b(4) & vbNewLine & _
b(5) & vbNewLine & _
b(6) & vbNewLine & _
b(7) & vbNewLine & _
b(8) & vbNewLine & _
b(9) & vbNewLine
.Comment.Text "Kaavan tulokset:" & vbNewLine & Vanha
End If
.Comment.Shape.TextFrame.AutoSize = True
End If
End With
End If
End Sub
Keep EXCELing
@Kunde - ko taulukon moduulin ...
tarkoittaa sen taulukon moduulia missä haluat koodia suorittaa, eli jos haluat Taul1
suorittaa makron , niin kopioi koodit sen moduuliin
Vasemmalla Project ikkunassa on Microsoft excel Objects ja siellä kaikki taulukon moduulit ja tuplaklikkaa haluamasi taulukon nimeä ja liitä oikealle valkealle ko taulukkoon... koodit
tavalliseen moduuliin
ylhäältä valikosta klikkaa INSERT/MODULE ja liitä oikealle valkealle alueelle tavalliseen moduuliin... koodit
KOODI TOIMII ILMAN ILMAN HIIREN OIKEAN NAPIN KLIKKAUSTA, eli kun menet soluun E6 aukeaa muokattu hiiren oikea valikko ja siinä kelpoisuusehdot. Klikkaat arvoja ja se liitetään soluun . Kun solusta poistutaan palutuu originaali hiiren valikko käyttööön
Toivottavasti nyt selkeni...
ko taulukon moduulin ...
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'solualue mihin haluat kelpoisuusehdon, nyt E6
If Not Intersect(Target, Range("E6")) Is Nothing Then
TeeValikko
Application.CommandBars("Cell").ShowPopup
Target.Offset(0, 1).Select
Else
Resetoi
End If
End Sub
tavalliseen moduuliin...
TeeValikko ()
tekee uuden hiiren oikean valikon
voit lisätä uusi kelpoisuusehtoja B sarakkeeseen nyt B39 alkaen.
LisääKelpoisuusehto()
lisää valikosta valitun tiedon aktiiviseen soluun
PoistaMenu()
tyhjentää originaali hiiren oikean valikon
Resetoi()
palauttaa orininaali hirren oikean valikon
Sub TeeValikko()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Long
Dim Vika As Long
Dim Solu As Range
PoistaMenu
Set ctrl = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=1)
'muuta otsikko sopivaksi
ctrl.Caption = "Lisää tekstit..."
'voi lisätä uusia kelpoisussehtoja ja koodi päivyttyy automaatisesti
Vika = Range("B65536").End(xlUp).Row
For Each Solu In Range("B39:B" & Vika)
Set btn = ctrl.Controls.Add
btn.Caption = Solu
btn.OnAction = "LisääKelpoisuusehto"
Next
End Sub
Private Sub LisääKelpoisuusehto()
ActiveCell = Application.CommandBars.ActionControl.Caption
End Sub
'poistaa kaikki jutut hiiren oikeasta valikosta
Sub PoistaMenu()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Cell").Controls
ctrl.Delete
Next
End Sub
'palauttaa originaali hiiren oikean valikon
Sub Resetoi()
Application.CommandBars("Cell").Reset
End Sub
Keep EXCELing
@Kunde - Sun olisi pitänyt suorittaa PoistaMenu() makro... ;-)
- ko taulukon moduulin ...
nyt kelpoisuusehto soluissa A1:A10, jos haluat vain yksittäiseen soluu esim C1, niin muuta Intersect(Target, Range("C1"))
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'solualue mihin haluat kelpoisuusehdon, nyt A1:A10
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
TeeValikko
Application.CommandBars("Cell").ShowPopup
Target.Offset(0, 1).Select
Else
Resetoi
End If
End Sub
tavalliseen moduuliin...
TeeValikko () tekee uuden hiiren oikean valikon
voit lisätä uusi kelpoisuusehtoja B sarakkeeseen nyt B39 alkaen.
LisääKelpoisuusehto() lisää valikosta valitun tiedon aktiiviseen soluun
PoistaMenu() tyhjentää originaali hiiren oikean valikon
Sub TeeValikko()
Dim ctrl As CommandBarControl
Dim btn As CommandBarControl
Dim i As Long
Dim Vika As Long
Dim Solu As Range
PoistaMenu
Set ctrl = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=1)
'muuta otsikko sopivaksi
ctrl.Caption = "Lisää tekstit..."
'voi lisätä uusia kelpoisussehtoja ja koodi päivyttyy automaatisesti
Vika = Range("B65536").End(xlUp).Row
For Each Solu In Range("B39:B" & Vika)
Set btn = ctrl.Controls.Add
btn.Caption = Solu
btn.OnAction = "LisääKelpoisuusehto"
Next
End Sub
Private Sub LisääKelpoisuusehto()
ActiveCell = Application.CommandBars.ActionControl.Caption
End Sub
'poistaa kaikki jutut hiiren oikeasta valikosta
Sub PoistaMenu()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Cell").Controls
ctrl.Delete
Next
End Sub
'palauttaa originaali hiiren oikean valikon
Sub Resetoi()
Application.CommandBars("Cell").Reset
End Sub
Keep EXCELing
@Kunde