kunde

kunde profiilikuva
Joulu 2024
Vapaa kuvaus

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 20v sitten
7 aloitusta · 1377 kommenttia
Uusimmat aloituksetSuosituimmat aloituksetUusimmat kommentit
moduuliin...
lisää nyt Komerojutut nimisen valikon ennen Ohje/Help valikkoa(Hipsaa käytettävän version mukaan- nyt enkkuversio käytössä)

Public Sub Auto_Open()
Dim cbWSMenuBar As CommandBar
Dim muCustom As CommandBarControl
Dim iHelpIndex As Integer

Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
'iHelpIndex = cbWSMenuBar.Controls("Ohje").Index
iHelpIndex = cbWSMenuBar.Controls("Help").Index
Set muCustom = cbWSMenuBar.Controls.Add(Type:=msoControlPopup, _
Before:=iHelpIndex)
With muCustom
.Caption = "Komerojutut"

With .Controls.Add(Type:=msoControlButton)
.Caption = "Laskehinta"
.OnAction = "Laskehinta"
End With

With .Controls.Add(Type:=msoControlButton)
.Caption = "CNC-siirto"
.OnAction = "AvaaCNC"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Järjestä"
.OnAction = "Järjestä"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Tulosta"
.OnAction = "Tulosta"
End With
End With
End Sub


Public Sub Auto_Close()
Dim cbWSMenuBar As CommandBar

On Error Resume Next
Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
cbWSMenuBar.Controls("Komerojutut").Delete
End Sub
Arrayhin haettavat luvut. Nyt "Tulos" taulukon soluun A1 vertailun tulos.

taulukon moduuliin...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Laskuri As Long
Dim Haettavat As Variant
Dim Loydettysolu As Range
Haettavat = Array(11, 22, 33, 44, 55)
With ActiveSheet
For Laskuri = LBound(Haettavat) To UBound(Haettavat)
Set Loydettysolu = .Range("B6:C9").Find(What:=Haettavat(Laskuri), MatchCase:=True)
If Loydettysolu Is Nothing Then
Sheets("Tulos").Range("A1") = 0
Else
Sheets("Tulos").Range("A1") = 1
Exit For
End If
Next Laskuri
End With
End Sub
tolla nyt alkuun. Muuta polku ja tiedostonnimi itsellesi sopivaksija muista tehda tallennuskansio polku osoitteeseen.
ThisWorkbook moduuliin...

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Const Polku = "C:\Varmuuskopiot\"
Dim Tiedostonnimi As String
Dim Laskuri As Long
Dim JoTallennettu As Boolean
On Error Resume Next
Application.EnableEvents = False
Laskuri = 1
Do
Tiedostonnimi = Polku & "MunTaulukko-" & Format(Laskuri, "0000") & ".xls"
JoTallennettu = Len(Dir(Tiedostonnimi))
If Not JoTallennettu Then
ActiveWorkbook.SaveAs Filename:=Tiedostonnimi
End If
Laskuri = Laskuri + 1
Loop Until Not JoTallennettu
Application.EnableEvents = True
Cancel = True
End Sub
lue vastaukseni tuolta
http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000032552691
helpointa lienee kopioida alue uuteen työkirjaan ja tallentaa se elikä allaoleva kysyy aluetta ja kirjoittaa solun B1 tekstin mukaan tiedoston esim. c:\hep\hep.txt


Sub Tallenna()
Dim Alue As Range
Dim Polku As String
On Error Resume Next
Application.DisplayAlerts = False
Polku = Range("B1")
Set Alue = Application.InputBox(prompt:="Valitse sarakealue", Type:=8)
Application.ScreenUpdating = False
Alue.Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=Polku, FileFormat:=xlTextMSDOS
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
vika on siinä kun rivejä poistetaan ne pitää poistaa alkaen lopustapäin.
Olen aikaisemmin postannut FIND funktion joka palauttaa alueen ja on tässäkin tapauksessa parhain ja nopein vaihtoehto. Yleensä pitäisi pyrkiä käyttämään excelin omia funktioita. For next loopit ovat niitä "tehottomimpia", mutta toimivia kuitenkin. Kysyjän tapauksessa nopeus ei varmaankaan nöyttele suurtakaan osuutta. Tossa nyt kuitenkin FIND makro ja sillähän voit tehdä sen tallennuksenkin yhdellä koodirillä toiseen taulukkoon...

Sub CommandButton1_Click()
EtsiAlue("EPÄTOSI", Columns("C"), xlFormulas, xlWhole).EntireRow.Copy Range("Sheet2!C65536").End(xlUp).Offset(1, 0).EntireRow
EtsiAlue("EPÄTOSI", Columns("C"), MatchCase:=True).EntireRow.Delete
End Sub

Function EtsiAlue(Haettava As Variant, _
Hakualue As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Range


Dim Alue As Range
Dim Ekaosoite As String
If IsMissing(LookIn) Then LookIn = xlValues
If IsMissing(LookAt) Then LookAt = xlPart
If IsMissing(MatchCase) Then MatchCase = False

With Hakualue
Set Alue = .Find( _
What:=Haettava, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not Alue Is Nothing Then
Set EtsiAlue = Alue
Ekaosoite = Alue.Address
Do
Set EtsiAlue = Union(EtsiAlue, Alue)
Set Alue = .FindNext(Alue)
Loop While Not Alue Is Nothing And Alue.Address Ekaosoite
End If
End With
End Function

Keep Excelling @Kunde
ei kyllä pitäisi noin tapahtua, mutta kokeiles tällä
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Target = Range("A1") Then
Range("B1") = Range("B1") + Range("A1")
End If
Application.EnableEvents = True
End Sub

jos haluat suoraan samaan soluun kumulatiivisen laskurin niin tolla tällä se onnistuuu

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Static Summa As Double
On Error Resume Next
Application.EnableEvents = False
If Target.Address = "$B$1" Then 'solu B1
Summa = Summa + Target.Value
Target.Value = Summa
End If
Application.EnableEvents = True
End Sub
Taulukon moduuliin ja muuta solut sopiviksi

Private Sub Worksheet_Change(ByVal Target As Range)
If Target = Range("A1") Then
Range("B1") = Range("B1") + Range("A1")
End If
End Sub
Jos ei tartte solusta lukea niin kayttokelpoisin tapa on kelpoisuusehdon sanomaruutu ja ruksi kun solu on valittuna kohtaan
kirjoita sana soluun ja tuplaklikkaa solun oikean reunan pikkuneliötä...
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
eikös se toimi muotoilullakin?
maalaa alue ja laita solumuotoiluksi esim. -0 tai jos desimaaleja haluat -0,00 jne
aikakysymykset ovat excelissä välillä "kinkkisiä", mutta koodaamalla se onnistuu ihan helposti.
Ilman koodiakin onnistuu esim. seuraavasti
soluun A1 solumuotoiluksi teksti ja syötetään 6 numeroinen aika 111207
soluun mihin halutaan päiväys näytettäväsi solumuotoiluksi päivämäärä ja sieltä sopiva esitystapa. Solun kaavaksi =TEKSTI(A1;"00-00-00")+0
nyt solun arvoa voi käyttää laskutoimituksissa.

Keep Exceling
@Kunde
Lisää excelissä viittaus ohjelmaan ja tallena labelin tieto muutujaan ja sitten käyttelet muuttujaa ohjelmassasi...
http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000019204656#22000000019204656
http://keskustelu.suomi24.fi/show.fcgi?category=108&conference=4500000000000708&posting=22000000014646147#22000000014646147
Ohjelmistona on Openoffice 2.3 ja sen exel sovellus...
CTRL+F11 lukitsee kentän ja silloin se ei päivity avattaessa. CTRL+SHIFT+F11 poistaa lukituksen ja kenttä päivittyy avattaessa. F9 päivittää tarvittaessa kentän tälle päivälle, jos olet poistanut lukituksen.
CTRL+SHIFT+F9 muuttaa kentän tekstiksi
nauhoita makro ja liitä siihen näppäinkomento tai tee nappi ja liitä makro siihen...
esim.makro

Sub Päiväys()
Selection.InsertDateTime DateTimeFormat:="d.M.yyyy"
End Sub
61 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt