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
- ei taida onnistua suomiasetuksilla jos desimaalierotin on .
mutta jos tulos tulee toisesta solusta niin
soluun kaava =TRUNC(A1;2)&" kN/m²"
AI on arvo solusta
2 desimaalien määrä - lisää uuden taulukon "Uusi" ja tekee siellä tarvittavat jutskat...
moduuliin...
Option Explicit
Sub Keskiarvo()
Dim Originaali As Range
Dim vika As Long
Dim i As Long
Dim lkm As Long
Dim solu 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
Rows("1:2").Insert
vika = Range("A65536").End(xlUp).Row
lkm = 2
For i = vika To 3 Step -1
If Format(Range("A" & i), "hh") = Format(Range("A" & i - 1), "hh") Then
Range("A" & i).Offset(-1, 1) = Range("A" & i).Offset(-1, 1) Range("A" & i).Offset(0, 1)
Range("A" & i).Offset(-1, 2) = Range("A" & i - 1).Offset(-1, 2) lkm
lkm = lkm 1
Range("A" & i).EntireRow.Delete
Else
lkm = 2
End If
Next
vika = Range("B65536").End(xlUp).Row
For Each solu In Range("B3:B" & vika)
solu = solu / solu.Offset(0, 1)
Next
Range("A:A").NumberFormat = "dd/yy/mm hh"
Range("B:B").NumberFormat = "0.00"
Range("C:C").Delete
Range("B2") = "Keskiarvo"
ActiveCell.Columns("A:B").EntireColumn.EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Keep EXCELing
@Kunde - palkat alueella A2:A9
ja kaava soluun matriisikaavana SHIFT CTRL ENTER
{=AVERAGE(IF(A2:A90;A2:A9))} - koodit liittämättä moduuliin...
- soluihin kaavat
taulukon nimi =Taulukonnimi()
sivujen lkm =Sivujenmäärä()
moduuliin...
Function Taulukonnimi() As String
Taulukonnimi = ThisWorkbook.Name
End Function
Function Sivujenmäärä() As Integer
Dim Vaaka As Integer
Dim Pysty As Integer
Application.Volatile True
Vaaka = ActiveSheet.HPageBreaks.Count 1
Pysty = ActiveSheet.VPageBreaks.Count 1
Sivujenmäärä = Vaaka * Pysty
End Function
Keep EXCELing
@Kunde - tietämättä mistä valikosta olet napit lisännyt tein nyt visual basic valikosta valintanapeille
taulukot 1 ja 2 oletuksena samoin nappien nimet
ThisWorkbook moduuliin...
Private Sub Workbook_BeforePrint(Cancel As Boolean)
On Error Resume Next
Application.EnableEvents = False
ActiveSheet.Select
Select Case True
Case Sheets("Taul1").OptionButton1
Sheets("Taul1").Select
Case Sheets("Taul1").OptionButton2
Sheets("Taul1").Select False
Sheets("Taul2").Select False
End Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1
Sheets("Taul1").Select
Cancel = True
Application.EnableEvents = True
End Sub - sanasto Taul2 sarakkeessa C
kirjoitettavat sanat Taul1 sarakkeessa A
kirjoita kirjain ja enter- jos löytyy uniikkivastine niin kirjoittaa sen, jos useampi vastine, niin jatka kirjain kerrallaan kunnes uniikki sana löytyy...
jos ei löydy vastinetta niin sitten hyväksyy kirjoitetun tekstin
jos haluat osan vastinesanasta niin silloin pitää lopettaa ALT ENTER ja vielä kerran ENTER
taulukon moduuliin...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim solu As Range
Dim Löydetty1 As Range
Dim Löydetty2 As Range
Dim Sanasto As Range
Dim Alue As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo virhe
Set Sanasto = Worksheets("Taul2").Range("C:C")
Set Alue = Worksheets("Taul1").Range("A:A")
For Each solu In Alue
If Not IsError(solu) Then
If solu "" And Right(solu, 1) Chr(10) Then
Set Löydetty1 = Nothing
Set Löydetty1 = Sanasto.Find(solu & "*", lookat:=xlWhole, MatchCase:=False)
If Not Löydetty1 Is Nothing Then
Set Löydetty2 = Sanasto.FindNext(after:=Löydetty1)
If Löydetty2.Address = Löydetty1.Address Then
solu = Löydetty1
Else
solu.Activate
Application.SendKeys ("{F2}")
End If
Else
End If
Else
If solu "" And Right(solu, 1) = Chr(10) Then solu = Left(solu, Len(solu) - 1)
End If
End If
Next solu
virhe:
Application.EnableEvents = True
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Keep EXCELing
@Kunde - ???
mitä ton oikeesti pitäs tehdä luvun syötön ja nappulan painalluksen jälkeen? - lisää kaljaa jemmaan...
nyt hard codena toi alueen siirtymä, mutta se nyt sitten helppo muokata sopivaksi muutujilla
Option Explicit
Sub PoistaTyhjätSarakkeet()
Dim Alue As Range
Dim Sarake As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Alue = Range("B8:AL100")
For Sarake = Alue.Columns.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Range(Alue(1, 1).Offset(0, Sarake - 1), Alue(93, 1).Offset(0, Sarake - 1))) = 0 Then
Alue.Columns(Sarake).EntireColumn.Hidden = True
End If
Next Sarake
virhe:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Keep EXCELing
@Kunde - Set Alue = Range(Columns(1), Columns(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column()))
toi hakee automaattisesti käytössäsi olevan alueen, eli etsii aina taulukosta viimeisen käytössä olevan solun sarakkeen 1-X ;-)
jos haluat kiinteän määrityksen niin sitten esim.
Set Alue = Columns("F:L")
Keep EXCELing
@Kunde
tattista vaan kunpahan sais joskus noi virtuaalit muunneetua todelliseksi niin sitten...
Keep ARCHAing
@Kunde - taivas varjele!
etkö muita kirjoitusvirheitä löytänyt? kyllä niitä on muitakin ; -)
nyt kuitenkin olennainen eli koodi toimiva joten ไม่เป็นไร - mitenkäs käyttäjä voisi sitten korjata vahinkovalinnan jos sattuisi klikkaamaan vahingossa väärää solua/aluetta ja ei olisi korjausmahdollisuutta?
uskon, että impossible mission
jos esim.käyttäisi selection change tapahtumaa sekin reagoi heti ekaan valintaan ja jos jotenkin kikkailisi, niin silti se valinta pitäisi sitten jotenkin kuitattua- eli unohda koko juttu. - ei siihen tartte kuin ladata fontti
esim
http://www.barcodesinc.com/free-barcode-font/
http://www.bizfonts.com/free/ - Oli hiukan tarvettava vastaavanlaiselle itselläkin, mutta tarvitsin sen tekstitietoon kirjoittamaan kuten lokitiedosto...
kalenterista valitaan päiväys ja tuo tekstiruutun tekstin, jos sille päivälle on kirjoitettu jotakin. Kirjoita napilla kirjoittaa sitten yakaisin tiedostoon tekstiruudun tekstin- eli päivitää sen päivän tekstit ja jos ei ole ko. päivälle tekstiä lisää sen tiedostoon- eli täysin muokattava tiedosto...
muokkasin tota yhdestä vanhasta postauksestani tänne vuosien takaa, nyt siis tiedosto näyttää tältä
esim. $212011 tarkoittaa 2.1.2001 pvm ja sen alla sitten kirjoitettu teksti. Koodi perustuu tohon dollaripäiväykseen ja helposti muokattavissa omiin tarpeisiin.
$212011
kukkuluuruu toimiiko?
$312011
hyvin toimii
$412011
uutta lisättyä
tietoa
pukkaa
$512011
lisätään tietoa
$612011
vielä
kerta
$712011
kiellon
$812011
päälle
lisää lomake ja siihen
2 commandbuttonia (Lopeta ja Kirjoita)
1 Calendar control i(jos ei oo työkaluvalikossa, klikkaa hiiren oikealla työvalikkoa ja lisää kontrolleja ja selaa ja valitse Calendar Control XX)
1 textbox
muuta polku ja tiedoston nimi sopivaksi
lomakkeen koodit oletusnimillä...
Option Explicit
Dim X As String
Private Sub Calendar1_Click()
Me.TextBox1 = LueTekstiFile("d:\Päiväkirja.txt", "$" & Replace(Calendar1.Value, ".", ""))
End Sub
Private Sub CommandButton1_Click()
End
End Sub
Private Sub CommandButton2_Click()
X = LueTekstiFile("d:\Päiväkirja.txt", "$" & Replace(Calendar1.Value, ".", ""))
If X = "" Then
KirjoitaTekstiFile "d:\Päiväkirja.txt", "$" & Replace(Calendar1.Value, ".", ""), "$" & Replace(Calendar1.Value, ".", "") & vbNewLine & Me.TextBox1, True
Else
KirjoitaTekstiFile "d:\Päiväkirja.txt", X, Me.TextBox1, False
End If
End Sub
textboxin ominaisuuksissa
EnterKeyBehavior=TRUE
WorldWrap=TRUE
Multiline=TRUE
normaali moduuliin...
Option Explicit
Function LueTekstiFile(TekstiFile As String, Alkurivi As String) As Variant
Dim Dollarimerkki As String
Dim Teksti As String
Dim Rivimäärä As Long
Dim Dollariteksti As Boolean
Dim Pituus As Long
Dim Tarkiste As Long
Dim Omatarkiste As Long
Dim Viesti As String
On Error GoTo virhe
Dollarimerkki = "*" & Alkurivi & "*"
Open TekstiFile For Input As #1
Do While Not EOF(1)
Line Input #1, Teksti
If Teksti Like Dollarimerkki Then
Dollariteksti = True
End If
If Dollariteksti = True Then
If Teksti = Alkurivi Then GoTo hyppy
If Teksti Like "*$*" Then GoTo loppu
LueTekstiFile = LueTekstiFile & Teksti & vbNewLine
End If
hyppy:
Loop
loppu:
Close #1
virhepoistu:
Exit Function
virhe:
Close #1
Viesti = Err.Description & " " & Err.Number
MsgBox Viesti, vbCritical, "Tiedostosta luku"
Resume virhepoistu
End Function
Sub KirjoitaTekstiFile(TekstiFile As String, Etsi As String, Korvaa As String, Lisää As Boolean)
Dim SeuraavaVapaa As Long
Dim VanhaTeksti As String
Dim UusiTeksti As String
SeuraavaVapaa = FreeFile
If Lisää Then
Open TekstiFile For Append As SeuraavaVapaa
Print #SeuraavaVapaa, Korvaa
Close #SeuraavaVapaa
Else
Open TekstiFile For Input As SeuraavaVapaa
VanhaTeksti = Input$(LOF(SeuraavaVapaa), SeuraavaVapaa)
Close SeuraavaVapaa
UusiTeksti = Replace(VanhaTeksti, Etsi, Korvaa)
SeuraavaVapaa = FreeFile
Open TekstiFile For Output As SeuraavaVapaa
Print #SeuraavaVapaa, UusiTeksti & vbNewLine
Close #SeuraavaVapaa
End If
End Sub
Keep EXCELing
@Kunde - helpoin ja vaivattomon tapa lienee tehdä tietolomake valikosta DATA/Form..
.
tee otsikot esim A1=pvm
B1=klo
C1= tapahtumat
lisää pvm:t sarakkeeseen A alkaen solusta A2 alaspäin
tee nappi ja liitä koodi siihen
Option Explicit
Sub Päiväkirja()
Range("A1").Select
ActiveSheet.ShowDataForm
End Sub
kilkkaa nappia ja lomake avautuu...
sitten vaan syöttelet tietoja poistelet etsit yms...
ohjeista löytyy hyvät kuvaukset lomakkeen toiminnoille.
Keep EXCELing
@Kunde - korvaa inputbox lomakkeella.
Lisää siihen textbox, label ja 2commandbuttonia OK ja Peruuta
oletusnimillä
Peruuta nappiin koodi...
Private Sub CommandButton2_Click()
End
End Sub
OK nappiin koodi...
Private Sub CommandButton1_Click()
If TextBox1.Text = "sala" Then
Sheets("taul2").Visible = True
Sheets("taul2").Select
End If
End Sub
ominaisuuksissa
labelin caption esim. Kirjoita salasana
lomakkeen caption salasana
textbox PasswordChar esim *
ton näytettävän merkin voit vapaasti valita...
Keep EXCELing
@Kunde - ihan perus phakujuttu
teet sen tiedoston kuten esitit ja sitten tulostettavalle lapulle laitat niihin kohtiin mihin haluat tietoa vaan phakukaavat - eikös katsastaa voi myöhässäkin...
lisäsin semmosen vaihtoehdon
taulukon moduuliin...
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
If Not Intersect(Target, Range("G3")) Is Nothing Then
HakeeSuljetusta
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
moduuliin...
Sub HakeeSuljetusta()
Dim wb As Workbook
Dim Löydetty As Range
Set wb = Workbooks.Open("D:\Exceliin.xls", True, True)
Set Löydetty = EtsiJaSiirrä(ThisWorkbook.Worksheets("Sheet1").Range("G3"), Range("C:C"))
With ThisWorkbook.Worksheets("Sheet1")
.Range("H5") = DateSerial(Year(Löydetty.Offset(0, 26)), Month(Löydetty.Offset(0, 26)), Day(Löydetty.Offset(0, 26)))
.Range("F5") = DateSerial(Year(Löydetty.Offset(0, 26)), Month(Löydetty.Offset(0, 26)) - 4, Day(Löydetty.Offset(0, 26)))
.Range("H6") = DateSerial(Year(Date), Month(Löydetty.Offset(0, 26)), Day(Löydetty.Offset(0, 26)))
.Range("F6") = DateSerial(Year(Date), Month(Löydetty.Offset(0, 26)) - 4, Day(Löydetty.Offset(0, 26)))
.Range("G8") = DateSerial(Year(Löydetty.Offset(0, 17)), Month(Löydetty.Offset(0, 17)), Day(Löydetty.Offset(0, 17)))
.Range("G9") = Date
'onko tämäpäivä katsastusajalla?-kyllä
If .Range("G9") = .Range("F6") Then
.Range("F15") = "OK"
'onko tämäpäivä katsastusajalla?-ei
Else
'tulossa?
If .Range("G9") - Option Explicit
Sub PoistaTyhjätSarakkeet()
Dim Alue As Range
Dim Sarake As Long
On Error GoTo virhe
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Alue = Range(Columns(1), Columns(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column()))
For Sarake = Alue.Columns.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Alue.Columns(Sarake).EntireColumn) = 0 Then
Alue.Columns(Sarake).EntireColumn.Delete
End If
Next Sarake
virhe:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Keep EXCELing
@Kunde - muuta tiedoston nimi sopivaksi.
Sub Macro1()
Workbooks.OpenText Filename:="E:\st.txt", Origin:=1257 _
, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True _
, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1)), TrailingMinusNumbers:=True
Columns("A:A").Insert Shift:=xlToRight
Columns("C:C").Cut Columns("A:A")
Columns("C:C").Delete
Range("A1").Select
End Sub
KeepEXCELing
@Kunde