kunde

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 aloitukset Suosituimmat aloitukset Uusimmat kommentit

Sub Eilinen()
On Error Resume Next
ActiveWorkbook.Unprotect
If Worksheets(Format(Date - 1, "dd.mm.yyyy")) Is Nothing Then
Worksheets("Default").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(Date - 1, "dd.mm.yyyy")
Else
MsgBox "EILINEN PÄIVÄMÄÄRÄ ON LISÄTTY JO!"
End If
ActiveWorkbook.Protect
End Sub

Keep EXCELing
@Kunde07.10.2011 04:21

siitäpä se johtuu- toi on bugi
korjautuu, jos

1. kopioit taulukon uuteen taulukkoon tai
2. tallennat työkirjan ja avaat sen uudelleen ja avaa valikossa klikkaat avaa nappulan(oikealla alhaalla) vaihtoehdoista avaa ja korjaa ja sitten vaan ok pari kertaa ja tallennat uudelleen...06.10.2011 05:18

moduuliin...
nyt lisää 5 riviä sarakkeen G nimien muuttuessa, muuta sopivaksi

Sub lisääRivit()
Range("G1").Select
Do Until ActiveCell = ""
If ActiveCell.Offset(1, 0) = "" Then Exit Sub
If ActiveCell = ActiveCell.Offset(1, 0) Then
ActiveCell.Offset(1, 0).Select
Else
Rows(ActiveCell.Row + 1 & ":" & ActiveCell.Row + 5).Insert
ActiveCell.Offset(6, 0).Select
End If
Loop
End Sub

Keep EXCELing
@Kunde06.10.2011 04:19

en usko vieläkään , että ilman makroa onnistuu...
miten välisummat pystyy tekemään merkinnät välillä oleville tunneille, jos se ilmoitetaan kuten esimerkissä eli esim(1) 10:02:30 ja (0)14:45:56. Miten ohjelma voi tosta lukea läsnäolo minuutit eri tunneille ja kirjata siitä ne taulukkoon ilman makroa

eli tälläinen tulos pitäisi saada tosta
klo -läsnäoloaika
10-58
11-60
12-60
13-60
14-45

ihmettelen suunnattomasti jos Calc ton tekee ;-)-29.09.2011 17:15

Listboxin ominaisuuksissa laita LinkedCell solun osoite, jota käytät PHAKU funktiossa29.09.2011 16:11

tuttumies:
missäs se tulostaulukko paikallaoloista minuuteissa/tunti?29.09.2011 04:14

sulla ei ole työkirjassa taulukkoa nimeltä Sheet1- muuta se oikeaksi28.09.2011 08:32

Käsittämättömän hieno ilmaisohjelma, jos pystyy pelkistä 0/1 laskemaan paikallaoloajan tunneille huomioiden 15 min poistot yms. ilman makroja.
Jollain on sitten ilmeisesti ollut tarvetta tehdä tommoinenkin oletusfunktio ilmaisohjelmaan. HIENOA

mutta asiaan:

"nythän siinä pyöristyksen jälkeen voi olla sekä 0 tai 1 samalla ajalla ja mitäs sitten tapahtuu???"
Huomasin, että jos haluaa esim. jonkun 15 minuutin poissa olon poistaa, niin pitää poistaa mittaus, jossa arvo menee 0 ja mittaus, jossa toi muuttuu takaisin 1.
selvitys selkeytti asiaa, toisaalta vois sitten kuitenkin laskea paikallaoloajan tunneille sekunnin tarkkuudella ...28.09.2011 03:31

moduuliin...
esim.

Sub Auto_Open()
Worksheets("Sheet1").Range("A1") = Worksheets("Sheet1").Range("A1") + 1
End Sub

Keep EXCELing
@Kunde27.09.2011 16:21

esim. A sarakkeessa maat ja combobox1 ListFillRangeksi esim A1:A10

B -K sarakkeissa sitten kunkin maan omat postinumerot omissa sarakkeissaan allekkain
Nimeä kunkin maan postinumeroalue maalaamalla numerot ja kirjoita maan nimi nimiruutuun ja ENTER

VB- työkaluvalikosta lisää kaksi comboboxia ...
kopioi koodi taulukon moduuliin ja muuta combonimet sopiviksi

Option Explicit
Private Sub ComboBox1_Change()
If ComboBox1.ListIndex > -1 Then
With ComboBox2
.ListFillRange = ComboBox1
.ListIndex = 0
End With
End If
End Sub

Keep EXCELing
@Kunde27.09.2011 16:15

joku ristiriita mallitiedostossa tai sitten en ymmärrä juttua. Nyt siis pyöristää tunnit ylöspäin 30 min väleille ja jos muutos puolikkaalla tunnilla silloin 0,5 muutoin voimassa oleva 0 tai 1
nyt mallissasi on kuitenkin loppupäivällä pelkkää ykköstä vaikka muutoksia tapahtuu ja vieläpä puolikkaalle tunnille?
vaatii parempia ohjeita
tossa nyt koodin pätkä mikä muuttaa ajat ja poistaa alle 15 min ajat

hipsujen paikkoja vaihtamalla voit kokeilla aikojen pyöristyksiä alas tai ylöspäin tai lähimpään 30 min...

nythän siinä pyöristyksen jälkeen voi olla sekä 0 tai 1 samalla ajalla ja mitäs sitten tapahtuu???

originaalikoodihan laskee keskiarvojatunneille, joten tulos on tietenkin väärä

Sub Keskiarvo()
Dim Originaali As Range
Dim vika As Long
Dim i As Long
Dim lkm As Long
Dim solu As Range
Dim alue As Range
On Error Resume Next

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set Originaali = Columns("A:B")
Worksheets("Uusi").Delete
On Error GoTo 0
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Uusi"
Originaali.Copy Range("A1")
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Columns("C:C").NumberFormat = "[hh]:mm:ss"
vika = Range("B65536").End(xlUp).Row
If Range("B1") = 0 Then
For i = 2 To vika Step 2
Range("B" & i).Offset(0, 1) = Range("A" & i + 1) - Range("A" & i)
Next
Else
For i = 1 To vika Step 2
Range("B" & i).Offset(0, 1) = Range("A" & i + 1) - Range("A" & i)
Next
End If
Columns("A:C").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("C1").Select
'1/96 =15 min (tunti 1/24 vrk ja 1/4 osa siitä)
Do Until ActiveCell > 1 / 96
ActiveCell.Offset(1, 0).Select
Loop
Range("A1:A" & ActiveCell.Row - 1).EntireRow.Delete
Columns("A:C").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
vika = Range("A65536").End(xlUp).Row
For Each solu In Range("A1:A" & vika)
'vba funktio pyöristää lähinpään alas tai ylöspäin
'solu = Mround(solu, 1 / 48)
'excelin oma pyöristää ylöspäin
solu = Application.WorksheetFunction.Ceiling(solu, 1 / 48)
'excelin oma pyöristää alaspäin
'solu = Application.WorksheetFunction.Floor(solu, 1 / 48)
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub27.09.2011 10:56

ei kovinkaan kummoinen juttu

ThisWorkbook moduuliin...

Private Sub Workbook_BeforePrint(Cancel As Boolean)
'solujen piilotuskoodi alku
'koodia...
'solujen piilotuskoodi loppu

ActiveWindow.SelectedSheets.PrintOut Copies:=1
Cancel = True
End Sub24.09.2011 19:57

tuplaklikkaa objektia ja koodisivu aukeaa ja oletuksena esim.

Private Sub CommandButton1_Click()
End Sub

ja tohon sitten liität koodin eli

Private Sub CommandButton1_Click()
ActiveWindow.SelectedSheets.PrintOut Copies:=3
End Sub22.09.2011 13:15

ilman nappia

ThisWorkbook moduuliin...

Private Sub Workbook_BeforePrint(Cancel As Boolean)
ActiveWindow.SelectedSheets.PrintOut Copies:=3
Cancel = True
End Sub22.09.2011 12:06

kyllähän sponsorointi kuulostaisi hyvältä...
ei se nyt kummonen jutska ollutkaan pikku kikkailulla...

Option Explicit

Sub LisääKuvaKommenttiin()
Dim vika As Long
Dim solu As Range
Dim leveys As Long
Dim korkeus As Long
On Error Resume Next
Application.ScreenUpdating = False
vika = Range("C65536").End(xlUp).Row
For Each solu In Range("C1:C" & vika)
If Not solu.Comment Is Nothing Then solu.Comment.Delete
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & solu & ".jpg").Select
leveys = Selection.Width
korkeus = Selection.Height
Selection.Delete
With solu
.AddComment
.Comment.Visible = False
.Comment.Shape.Fill.UserPicture ThisWorkbook.Path & "\" & solu & ".jpg"
.Comment.Shape.Height = korkeus
.Comment.Shape.Width = leveys
End With
Next
Application.ScreenUpdating = True
End Sub

Keep EXCELing
@Kunde21.09.2011 17:53

meinaatkos , että kommentissa oleva kuva olisi alkuperäisen kokoinen?
kaipa toikin onnistuu, kun jollain keinolla saa luettua fiksusti kuvan koon21.09.2011 12:21

korjasin noi soluosoitteet isommiksi
ainakin mulla pelaa v 2010

Sub KopioiJaSiirrä()
Dim vika As Long
Dim vika2 As Long
Dim kopio As Range
Dim i As Long
On Error Resume Next
Taul1.Activate
Sheets("Taul2").Range("A1:B" & Sheets("Taul2").Range("A1045876").End(xlUp).Row) = ""
vika = Sheets("Taul1").Range("D1045876").End(xlUp).Row
For Each solu In Sheets("Taul1").Range("D1:D" & vika)
If solu "" And IsNumeric(solu) Then
Set kopio = solu.Offset(0, -2).Resize(1, 2)
For i = 1 To solu.Value
vika2 = Sheets("Taul2").Range("A1045876").End(xlUp).Row
If vika2 = 0 Then
vika2 = 1
Else
vika2 = vika2 + 1
End If
kopio.Copy Destination:=Sheets("Taul2").Range("A" & vika2)
Next i
End If
Next
End Sub21.09.2011 10:59

niin se kehitys kulkee eteenpäin.
aikanaan Excelissä oli max 65536 riviä.
versiossa 2007 rivimäärä kasvoi max 1,048,576 riviin.

koodissani olen käyttänyt Integer muuttujaa max 32767
nyt se kuitenkin pitäisi muuttaa Long tyyppiksi max 2147483647

Sub KopioiJaSiirrä()
Dim vika As Long
Dim vika2 As Long
Dim kopio As Range
Dim i As Long
On Error Resume Next
Taul1.Activate
Sheets("Taul2").Range("A1:B" & Sheets("Taul2").Range("A65536").End(xlUp).Row) = ""
vika = Sheets("Taul1").Range("D65536").End(xlUp).Row
For Each solu In Sheets("Taul1").Range("D1:D" & vika)
If solu "" And IsNumeric(solu) Then
Set kopio = solu.Offset(0, -2).Resize(1, 2)
For i = 1 To solu.Value
vika2 = Sheets("Taul2").Range("A1").End(xlDown).Row
If vika2 = 0 Then
vika2 = 1
Else
vika2 = vika2 + 1
End If
kopio.Copy Destination:=Sheets("Taul2").Range("A" & vika2)
Next i
End If
Next
End Sub

Keep EXCELing
@Kunde21.09.2011 09:16

25 / 69

kunde

Totta on asia. Jeffrey Cohen on jättänyt Sofian.

Salkkareilta jättiyllätys! 5000. erikoisnäytös ympäri Suomen tällä viikolla - Pettymys tv-katsojille

Rekat seisovat dieselin hinnan takia . Ala ei kestä tällaista hintatasoa, sanoo yrittäjä .

Sami Helenius oli jättämässä TTK:n viime vuonna - Pyörsi päätöksensä erikoisesta syystä: "Ehkä..."

Jos haluaa töihin, pitää yksinkertaisesti lähteä töihin

Maajussi-Jetta saa täyslaidallisen - "Hiihtosulho" pamauttaa mustasukkaisuudesta: "Mitä sutinaa...?"

Horoskooppi: Vaaka - älä vaivu synkkyyteen - Oinas, tee voitavasi - Rapu, ole aktiivinen

Pääministeri Petteri Orpo kertoi syksyllä 2024 hallituksella olevan 500 kasvuohjelmaa

Pettymys TTK-parketilla! Anna Hanski tippui - Sami-opelta erikoinen heitto: "Nyt sä pääset..."

Sain uuden työpaikan ja sairastuin heti alussa