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

Aloituksia

7

Kommenttia

1374

  • Uusimmat aloitukset
  • Suosituimmat aloitukset
  • Uusimmat kommentit
  1. koodit liittämättä moduuliin...
  2. 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
  3. 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
  4. 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
  5. ???
    mitä ton oikeesti pitäs tehdä luvun syötön ja nappulan painalluksen jälkeen?
  6. 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
  7. 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
  8. taivas varjele!
    etkö muita kirjoitusvirheitä löytänyt? kyllä niitä on muitakin ; -)
    nyt kuitenkin olennainen eli koodi toimiva joten ไม่เป็นไร
  9. 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.
  10. ei siihen tartte kuin ladata fontti
    esim
    http://www.barcodesinc.com/free-barcode-font/
    http://www.bizfonts.com/free/
  11. 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
  12. 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
  13. 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
  14. ihan perus phakujuttu
    teet sen tiedoston kuten esitit ja sitten tulostettavalle lapulle laitat niihin kohtiin mihin haluat tietoa vaan phakukaavat
  15. 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")
  16. 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
  17. 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
  18. koodaamalla melko helppo juttu....
    mutta miksi sun pitää WORD siihen sotkea, kun sen voi tehdä ihan yhtä hyvin suoraan EXCELissä paljon paljon pienemmällä vaivalla?
  19. mitä tolla T sarakkeen tiedolla sitten on merkitystä?
    Mihin sitä tarvitaan?

    ei aukea mulle- ei sitten millään...
  20. sama enkkuversio mullakin, mutta SP3 lisäksi.
    Todella outoa on toi "ei toimivuus" - ei muuten toiminut mullakaan enää toi ekaversio???
    Muokkasin ton jälkimmäisen siitä ja se toimii ihan jees
    21. 30 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt