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
- 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
@Kunde - 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... - 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
@Kunde - 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 ;-)- - Listboxin ominaisuuksissa laita LinkedCell solun osoite, jota käytät PHAKU funktiossa
- tuttumies:
missäs se tulostaulukko paikallaoloista minuuteissa/tunti? - lähetä mulle mallitiesoto siitä missä se bugi esiintyy
kundepuu@yahoo.com
muutokset
Sub Teetaulukko()
Dim vika As Long
Dim solu As Range
Dim i As Long
Dim j As Long
Dim viikko As Long
With Worksheets("Koonti")
.Activate
.Cells = ""
.Range("B1") = "viikko:"
.Range("B2") = "klo"
.Range("C1").Formula = "1"
LisääSarjat Range("C1"), 1, 52
LisääSarjat2 Range("A3")
End With
Worksheets("Uusi").Activate
vika = Range("A65536").End(xlUp).Row
For Each solu In Range("A1:A" & vika)
viikko = ViikkoISO(CDate(solu))
If solu.Offset(0, 1) = 1 Then
solu.Offset(0, 3) = Format(solu solu.Offset(0, 2), "yyyy-mm-dd hh:mm:ss")
solu.Offset(0, 4) = Format(solu, "hh")
solu.Offset(0, 5) = Format(solu solu.Offset(0, 2), "hh")
solu.Offset(0, 6) = Minute(solu)
solu.Offset(0, 7) = Minute(solu.Offset(0, 3))
If solu.Offset(0, 5) < solu.Offset(0, 4) Then solu.Offset(0, 5) = solu.Offset(0, 5) 24
'siirretään
'sama tunti
If solu.Offset(0, 4) = solu.Offset(0, 5) Then
'näyttää tunnit 1/100 tarkkuudella
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2).NumberFormat = "0.00"
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) = (Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) CDbl(Minute(solu.Offset(0, 2)))) / 60
'tunnin ero
Else
If solu.Offset(0, 5) - solu.Offset(0, 4) = 1 Then
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2).NumberFormat = "0.00"
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) = (Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) CDbl(60 - Minute(solu))) / 60
Worksheets("Koonti").Range(UCase(Format(solu.Offset(0, 3), "dddd"))).Cells(Format(solu.Offset(0, 3), "hh") 1, viikko 2).NumberFormat = "0.00"
Worksheets("Koonti").Range(UCase(Format(solu.Offset(0, 3), "dddd"))).Cells(Format(solu.Offset(0, 3), "hh") 1, viikko 2) = (Worksheets("Koonti").Range(UCase(Format(solu.Offset(0, 3), "dddd"))).Cells(Format(solu.Offset(0, 3), "hh") 1, viikko 2) CDbl(Minute(solu.Offset(0, 3)))) / 60
'usean tunnin ero
Else
For i = solu.Offset(0, 4) To solu.Offset(0, 5)
If i = solu.Offset(0, 4) Then
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2).NumberFormat = "0.00"
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) = (Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) CDbl(60 - Minute(solu))) / 60
Else
If i = solu.Offset(0, 5) Then
Worksheets("Koonti").Range(UCase(Format(solu.Offset(1, 0), "dddd"))).Cells(Format(solu.Offset(1, 0), "hh") 1, viikko 2).NumberFormat = "0.00"
Worksheets("Koonti").Range(UCase(Format(solu.Offset(1, 0), "dddd"))).Cells(Format(solu.Offset(1, 0), "hh") 1, viikko 2) = (Worksheets("Koonti").Range(UCase(Format(solu.Offset(1, 0), "dddd"))).Cells(Format(solu.Offset(1, 0), "hh") 1, viikko 2) Minute(solu.Offset(1, 0))) / 60
' vrk vaihtuu
Else
If i > 23 Then
j = i - 24
Worksheets("Koonti").Range(UCase(Format(solu.Offset(1, 0), "dddd"))).Cells(j 1, viikko 2) = 1
Else
j = i
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(j 1, viikko 2) = 1
End If
End If
End If
Next
End If
End If
End If
Next
Worksheets("Koonti").Cells.EntireColumn.AutoFit
Worksheets("Koonti").Activate
End Sub
Sub LisääSarjat2(solu As Range)
Dim i As Long
With Worksheets("Koonti")
solu.Select
For i = 1 To 7
ActiveCell = UCase(WeekdayName(i))
ActiveCell.Offset(0, 1).Formula = "0"
ActiveCell.Offset(0, 1).AutoFill Destination:=Range(ActiveCell.Offset(0, 1).Address & ":" & ActiveCell.Offset(23, 1).Address), Type:=xlFillSeries
ActiveWorkbook.Names.Add Name:=ActiveCell, RefersTo:=Range(ActiveCell.Address & ":" & ActiveCell.Offset(23, 54).Address)
Range(ActiveCell) = 0
ActiveCell.Offset(26, 0).Select
Next
End With
End Sub - laskee nyt minuutin tarkkuudella läsnäolot - kiireiltäni en ehtinyt testaamaan paljoakaan, mutta näyttäis menevän oikein
ei saanut lähetetttyä kaikkea koodia(sisältö liian pikä...), mutta ne muut koodinpätkät ei oo muuttunut
Option Explicit
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
Dim Löydetty 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
'haetaan läsnäoloajat C sarakkeeseen
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
'lisätään ajat taulukkoon
Teetaulukko
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Teetaulukko()
Dim vika As Long
Dim solu As Range
Dim i As Long
Dim j As Long
Dim viikko As Long
With Worksheets("Koonti")
.Activate
.Cells = ""
.Range("B1") = "viikko:"
.Range("B2") = "klo"
.Range("C1").Formula = "1"
LisääSarjat Range("C1"), 1, 52
LisääSarjat2 Range("A3")
End With
Worksheets("Uusi").Activate
vika = Range("A65536").End(xlUp).Row
For Each solu In Range("A1:A" & vika)
viikko = ViikkoISO(CDate(solu))
If solu.Offset(0, 1) = 1 Then
solu.Offset(0, 3) = Format(solu solu.Offset(0, 2), "yyyy-mm-dd hh:mm:ss")
solu.Offset(0, 4) = Format(solu, "hh")
solu.Offset(0, 5) = Format(solu solu.Offset(0, 2), "hh")
solu.Offset(0, 6) = Minute(solu)
solu.Offset(0, 7) = Minute(solu.Offset(0, 3))
If solu.Offset(0, 5) < solu.Offset(0, 4) Then solu.Offset(0, 5) = solu.Offset(0, 5) 24
'siirretään
'sama tunti
If solu.Offset(0, 4) = solu.Offset(0, 5) Then
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2).NumberFormat = "General"
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) = Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) CDbl(Minute(solu.Offset(0, 2)))
'tunnin ero
Else
If solu.Offset(0, 5) - solu.Offset(0, 4) = 1 Then
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) = Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) CDbl(60 - Minute(solu))
Worksheets("Koonti").Range(UCase(Format(solu.Offset(0, 3), "dddd"))).Cells(Format(solu.Offset(0, 3), "hh") 1, viikko 2) = Worksheets("Koonti").Range(UCase(Format(solu.Offset(0, 3), "dddd"))).Cells(Format(solu.Offset(0, 3), "hh") 1, viikko 2) CDbl(Minute(solu.Offset(0, 3)))
'usean tunnin ero
Else
For i = solu.Offset(0, 4) To solu.Offset(0, 5)
If i = solu.Offset(0, 4) Then
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) = Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(Format(solu, "hh") 1, viikko 2) CDbl(60 - Minute(solu))
Else
If i = solu.Offset(0, 5) Then
Worksheets("Koonti").Range(UCase(Format(solu.Offset(1, 0), "dddd"))).Cells(Format(solu.Offset(1, 0), "hh") 1, viikko 2) = Worksheets("Koonti").Range(UCase(Format(solu.Offset(1, 0), "dddd"))).Cells(Format(solu.Offset(1, 0), "hh") 1, viikko 2) Minute(solu.Offset(1, 0))
' vrk vaihtuu
Else
If i > 23 Then
j = i - 24
Worksheets("Koonti").Range(UCase(Format(solu.Offset(1, 0), "dddd"))).Cells(j 1, viikko 2) = 60
Else
j = i
Worksheets("Koonti").Range(UCase(Format(solu, "dddd"))).Cells(j 1, viikko 2) = 60
End If
End If
End If
Next
End If
End If
End If
Next
Worksheets("Koonti").Cells.NumberFormat = "General"
Worksheets("Koonti").Cells.EntireColumn.AutoFit
Worksheets("Koonti").Activate
End Sub
Keep EXCELing
@Kunde - sulla ei ole työkirjassa taulukkoa nimeltä Sheet1- muuta se oikeaksi
- 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 ... - moduuliin...
esim.
Sub Auto_Open()
Worksheets("Sheet1").Range("A1") = Worksheets("Sheet1").Range("A1") 1
End Sub
Keep EXCELing
@Kunde - 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
@Kunde - 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 Sub - 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 Sub - 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 Sub - ilman nappia
ThisWorkbook moduuliin...
Private Sub Workbook_BeforePrint(Cancel As Boolean)
ActiveWindow.SelectedSheets.PrintOut Copies:=3
Cancel = True
End Sub - 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
@Kunde - meinaatkos , että kommentissa oleva kuva olisi alkuperäisen kokoinen?
kaipa toikin onnistuu, kun jollain keinolla saa luettua fiksusti kuvan koon - 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 Sub - 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
@Kunde