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. kun ei ole milloin muuttujaa määritelty oikein- eli toimii vain kerran

    tossa minuutin ajolle makro

    Public milloin As Double
    Public Loppu As Double
    Sub aja()
    Loppu = Now + TimeSerial(0, 1, 0)
    Luku
    End Sub
    Sub Luku()
    Range("A1").Value = Rnd(1) * 1500
    milloin = Now + TimeValue("00:00:01")
    Application.OnTime milloin, "luku", Loppu
    End Sub
  2. tee lomakkeelle tekstiruutu ja komentopainike oletusnimillä

    pituus - Len(TextBox1.Text)
    ja valitsee koko tekstin ja muuttamalla esim. TextBox1.SelStart=2
    TextBox1.SelLength=2
    tekstistä merkit 3-4

    Private Sub CommandButton1_Click()
    TextBox1.SetFocus
    TextBox1.SelStart = 0
    TextBox1.SelLength = Len(TextBox1.Text)
    End Sub

    vastaavasti solusta - Len(Range("A1"))

    sub Koe()
    MsgBox Len(Range("A1"))
    End sub
  3. laita solumuotoiluksi oma "0"0
  4. kopioi nyt aina seuraavaan taulukkoon edellisen taulukon tiedot

    Sub Workbook_Open()
    Application.OnKey "{PGDN}", "Seuraava"
    End Sub

    Sub Workbook_Close()
    Application.OnKey "{PGDN}"
    End Sub

    Sub Seuraava()
    On Error Resume Next
    Range("A1:C2").Copy Destination:=Sheets(ActiveSheet.Index + 1).Range("A1")
    Sheets(ActiveSheet.Index + 1).Range("A2") = Sheets(ActiveSheet.Index + 1).Range("A2") + 1
    End Sub
  5. referensseistä
    Mulla näkyi olevan
    SCRRUN:DLL ja se löytyy mulla C:\WINDOWS\system32 kansiosta
  6. Auto_Open()
    teet omat valikot
    Auto_Close()
    palautat valikot
  7. Sub Vika()
    Range("A65536").End(xlUp).End(xlToRight).Select ' vika tietoa sisältävä rivillä
    'Range("A65536").End(xlUp).End(xlToRight).Offset(0, 1).Select' eka tyhjä rivillä
    End Sub
  8. moduuliin...

    Sub LajitteleSarakkeittain(Taulukko As String, Alue As String)
    Dim Sarakkeet As Integer
    Dim Rivit As Integer
    Dim Solujenlkm As Integer
    Dim s As Integer
    Dim r As Integer
    Dim laskuri As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets("Huuhaa").Delete
    Worksheets.Add().Name = "Huuhaa"
    Worksheets("Huuhaa").Activate
    range("A1") = "luvut"
    For Each solu In range(Taulukko & "!" & Alue)
    range("A65536").End(xlUp).Offset(1, 0) = solu.Value
    Next solu
    range("A1", range("A1").End(xlDown)).Sort Key1:=range("A2"), _
    Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Sheets(Taulukko).Activate
    range(Alue).Cells(1, 1).Activate
    Sarakkeet = range(Alue).Columns.Count
    Rivit = range(Alue).Rows.Count
    Solujenlkm = range(Alue).Cells.Count
    laskuri = 2
    For s = 1 To Sarakkeet
    For r = 1 To Rivit
    range(ActiveCell.Address).Offset(r - 1, s - 1).Value = _
    range("Huuhaa!A" & laskuri).Value
    laskuri = laskuri + 1
    Next r
    Next s
    Sheets("Huuhaa").Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    End Sub
    Sub koe()
    LajitteleSarakkeittain "Taul1", "A1:H10"
    End Sub
  9. eikös se tuolta käsin toimi kaikissa työkirjoissa. Eli tallenna Taulukot.xls sinne
  10. moduuliin... ja viittaus Microsoft Scripting Runtime kirjastoon
    voit hakea muitakin tietoja lisäämällä
    Range("A" & rivi) = Tiedosto.(ja valikosta lisää)

    Sub Testi()
    Columns("A:E") = ""
    Range("A1").Formula = "Tiedoston nimi:"
    Range("B1").Formula = "Tiedoston koko kt:"
    Range("C1").Formula = "Tiedoston tyyppi:"
    Range("D1").Formula = "Luotu pvm:"
    Range("E1").Formula = "Muokattu viimeksi pvm:"
    Range("A1:E1").Font.Bold = True
    Listaa "C:\Testikansio"
    End Sub

    Sub Listaa(LähdeKansionNimi As String)
    Dim FSO As Scripting.FileSystemObject
    Dim LähdeKansio As Scripting.Folder
    Dim Tiedosto As Scripting.File
    Dim rivi As Long
    Set FSO = New Scripting.FileSystemObject
    Set LähdeKansio = FSO.GetFolder(LähdeKansionNimi)
    rivi = Range("A65536").End(xlUp).Row + 1
    For Each Tiedosto In LähdeKansio.Files
    Range("A" & rivi) = Tiedosto.Name
    Range("B" & rivi) = Tiedosto.Size
    Range("C" & rivi) = Tiedosto.Type
    Range("D" & rivi) = Tiedosto.DateCreated
    Range("E" & rivi) = Tiedosto.DateLastModified
    rivi = rivi + 1
    Next Tiedosto
    Columns("A:E").AutoFit
    Set Tiedosto = Nothing
    Set LähdeKansio = Nothing
    Set FSO = Nothing
    End Sub
  11. funktiohan palauttaa arvon, jota voi käyttää vertailuissa yms.
    lisäämällä funktioon palautustyypin se on käytännöllinen esim. tyyliin

    Public Function testi(taulukko As String, mm As Integer) As Double

    Dim P As Double, L As Double

    P = Application.WorksheetFunction.VLookup(mm, Workbooks("TestiWb").Sheets(taulukko).Range("b2:j11"), 2)
    L = Application.WorksheetFunction.VLookup(mm, Workbooks("TestiWb").Sheets(taulukko).Range("b2:j11"), 3)

    testi = P + L * mm

    End Function
  12. aika pitkällehän oletkin päässyt :-)
    taulukon moduuleitahan ei voi poistaa, joten on poistettava sisältö...

    ennen tallennusta aja seuraava makro
    vaatii referenssin Visual Basic Extensibility ja makrojen suojauksessa täpän kohtaan luota Visual Basic projekteihin luotettavat lähteet välilehdellä.

    Sub PoistaKoodit(Työkirja As Workbook, ModuulinNimi As String)
    On Error Resume Next
    With Työkirja.VBProject.VBComponents(ModuulinNimi).CodeModule
    .DeleteLines 1, .CountOfLines
    End With
    On Error GoTo 0
    End Sub

    Sub Testi()
    PoistaKoodit ActiveWorkbook, "Taul1"
    'suorita tarvittaessa muillekin taulukoille
    'PoistaKoodit ActiveWorkbook, "Taul2"
    'PoistaKoodit ActiveWorkbook, "Taul3"
    End Sub
  13. ei ole helppoa tehdä ilman VBA:ta, mutta jos kerrot minkälaista kaavaa olet vailla niin yritän vääntää sellaisen ilman VBa:ta... Ei taida onnistua joka kaavalle
  14. ulkomuistista... VbLeft en ole varma miten se kirjoitetaan mutta ainakin {F1} on oikea muoto...

    Sub Auto_Open()
    Application.OnKey "{VbLeft}", "Vasemmalle"
    Application.OnKey "{VbRight}", "Oikealle"
    End Sub

    Sub Auto_Close()
    Application.OnKey "{VbLeft}"
    Application.OnKey "{VbRight}"
    End Sub
  15. lisasitko kaavion olemassaolevaan taulukkoon vaiko lisasitko sen uuteena taulukkona, jolloin siita tulee kaavion niminen taulukko. Tota jalkimmaista ajattelin lahinna...
  16. että allaolevat makrot eivat toimi oikein. Ei ole excelia tässä hotellin koneessa, mutta entapa jos tyokirja sisaltaa kaavioita :-)ja kumpikaan ei kasitellyt viimeista taulukkoa ekaa tosin kyllakin...
    palaan parin pv paasta asiaan, jos muut ei ole korjannneet tai olin vaarassa
    Keep exceling
  17. taulukon nimilehtien vasemmalla puolella on taulukoiden valintanuolinäppäimiä. Klikkaa hiiren oikealla ja valitse haluamasi taulukko...
    Keep Exceling ;-)
  18. oletuksena nyt eka taulukko, jota testataan

    Private Sub Workbook_BeforePrint(Cancel As Boolean)

    Dim mySolu As Range

    If ActiveSheet.Name = Worksheets(1).Name Then
    For Each mySolu In Range("tarkistaNamaSolut")
    If mySolu = "" Then
    Cancel = True
    MsgBox ("Et voi tulostaa! tietoja puuttuu ")
    Exit Sub
    End If
    Next mySolu
    End If

    End Sub
  19. kysyjä halusikin vain arvot...

    Sub Kopioi()
    On Error Resume Next
    Range("Taul1!B2:M2").Copy 'muuta aluetta tarvittaessa
    Range("Taul2!B65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues) 'kopioi B sarakkeesta alkaen muuta tarvittaessa
    End Sub
  20. Mikä virheilmoitus tulee jos hipsaat On Error Resume Next rivin?
    Ainakin mulla kopioi Taul1 alueen B2:M2 Taul2 aina seuraavalle vapaalle riville B sarakkeessa
    21. 64 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt