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. äkkiseltään vosi olla helpoin yhdistellä mun tämän foorumin postauksia...
    ilmeisesti jossain taulukossa on on kaikki tarvittavat tiedot? Jos näin on niin silloin tee haku uniikit/poistatuplat yms mun postauksista ja saat funktiolla uniikit arvot kerättyä yhdistelmäruutuusi (tarpeeksi sarakkeita comboboxiin).
    Change/Click tapahtumassa käytät sitten valintaa ja ja siirät ko. yhdistelmäruudun valinnan tarvittavaan yhdistelmäruutuun sarakeoffsettina esim .Column(1)
    tai sitten
    hae mun postauksista etsijasiirrä /haejasiirrä yms. monitoimifunktiota ja käytä sen palautuksena offsetteja, jotka siirrät haluamaasi yhdistelmäruutuun
    Ei pitäs olla liian hankalaa- siis HAKUA peliin...

    Keep Excelling
    @Kunde
  2. lisää välilaskennasta
    valikosta
    TYÖKALUT/KAAVAN TARKISTAMINEN/KAAVAN LASKEMINEN voi testailla aktiivisen solun kaavan laskentaa
    ja jos haluaa automatisoida esim. hiirtä tuplaklikkaamalla lomake näkyviin niin

    ko. taulukon moduuliin...

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.Dialogs(xlDialogEvaluateFormula).Show
    Cancel = True
    End Sub

    ja jos haluaa tuplaklikkauksen toimivan normaalisti lomakkeen sulkemisen jälkeen niin hipsaa koodissa rivi Cancel = True

    edelliselle...
    kannattaisi testata kaavojen toiminta ennenkuin postaa niitä!
    Kaavasi toimii hyvin matriisikaavana ja sen olen jo aiemmin postannut tänne, mutta tavallisena kaavana ei toimi...
  3. apusarakkeethan on ihan OK.
    Mutta jos sulla on joku valmis tulostuspohja mihin tarttee tehdä uusia laskelmia, niin apusarake on sijoitettava tulostusalueen ulkopuolelle. Nähdäkseen apusarakkeen taulukkoa pitää sitten scrollata, ja useinhan se pitää myös piilottaa tulostuksissa, jos vaikka sitä apusaraketta voisikin käyttää tulostusalueella...
    Ei merkkien määrä ole ratkaiseva (vertaa koodissa rivit) vaan tehokkuus, luettavuus ja muokkauksen helppous. Jos monta apusaraketta- monta paikkaa muokattavaa.

    Toisaalta vaiheittaisen laskemisen tarkistus on helppoa...
    esim. kaavassani {=SUMMA(JOS(A1:A4
  4. =SUMMA(SUMMA.JOS(A1:A4;{"0"})*{-1;1})

    matriisikaavoina CRTL+SHIFT+ENTER
    {=SUMMA(ITSEISARVO(A1:A4))}

    {=SUMMA(JOS(A1:A4
  5. muutetut versiot...
    Sub AvaaOmaKansio()
    Dim Palautus As Variant
    ChDir "C:\Documents and Settings\xxxxxxx\Desktop\Omat\"
    Palautus = Application.GetOpenFilename("Kaikki Excel tiedostot (*.xl*)," & "*.xl*", 1, "Valitse Tiedosto", "Open", False)
    If TypeName(Palautus) = "Boolean" Then
    Exit Sub
    End If
    'Workbooks.Open Palautus
    Range("Taul1!A1") = Mid(Palautus, InStr(1, Palautus, "\") + 1, Len(Palautus) - InStr(1, Palautus, "\") - 4)
    End Sub

    Sub AvaaOmaKansio2()
    Dim Palautus As Variant
    ChDir "C:\Documents and Settings\xxxxxxx\Desktop\Omat\"
    Palautus = Application.Dialogs(xlDialogOpen).Show
    If TypeName(Palautus) = "Boolean" Then
    Exit Sub
    End If
    'Workbooks.Open Palautus
    Range("Taul1!A1") = Mid(Palautus, InStr(1, Palautus, "\") + 1, Len(Palautus) - InStr(1, Palautus, "\") - 4)
    End Sub
    Keep Excelling
    @Kunde
  6. Sub AvaaOmaKansio()
    Dim Palautus As Variant
    ChDir "C:\Documents and Settings\xxxxxxx\Desktop\Omat\"
    Palautus = Application.GetOpenFilename("Kaikki Excel tiedostot (*.xl*)," & "*.xl*", 1, "Valitse Tiedosto", "Open", False)
    If TypeName(Palautus) = "Boolean" Then
    Exit Sub
    End If
    Workbooks.Open Palautus
    End Sub

    Sub AvaaOmaKansio2()
    Dim Palautus As Variant
    ChDir "C:\Documents and Settings\xxxxxxx\Desktop\Omat\"
    Palautus = Application.Dialogs(xlDialogOpen).Show
    If TypeName(Palautus) = "Boolean" Then
    Exit Sub
    End If
    Workbooks.Open Palautus
    End Sub

    Keep Excelling
    @Kunde
  7. tulevaisuudessa
    päiväys solussa H2
    solussa E1 on vuodet
    solussa E2 on kuukaudet
    solussa E3 on päivät
    =PÄIVÄYS(VUOSI(H2)+E1;KUUKAUSI(H2+E2);PÄIVÄ(H2)+E3)
  8. ihan hyvin kun pilkut puolipisteeksi ja lopuksi kaavarivillä CTRL+SHIFT+ENTER.
    Kyseessä on nimittäin matriisikaava...
  9. kommentti ei kelpaa, niin käytä harvemmin käytettyä N funktiota kaavassa ja voit kätevästi kommentoida kaavasi kaavariville...
    eli esim.
    =JOS(A1=0;1;0)+N("Laskee kuukausisumman jos A1=1 muuten...")
  10. niin tsekataan
  11. sulla on KAKSI SAMANNIMISTÄ Worksheet_Change proseduuria moduulissa...
    poista toinen
  12. pitää yhdistää...
    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Target, Range("K5,K7,K9")) Is Nothing Then
    Select Case Target.Address
    Case "$K$5"
    Range("B11") = Target
    Case "$K$7"
    Range("B20") = Target
    Case "$K$9"
    Range("C29") = Target
    End Select

    If Not Intersect(Target, Range("B11,B20,C29")) Is Nothing Then
    Select Case Target.Address
    Case "$B$11"
    Range("K5") = Target
    Case "$B$20"
    Range("K7") = Target
    Case "$C$29"
    Range("K9") = Target
    End Select
    End If
    Application.EnableEvents = True
    End Sub
    Sub Resetoi()
    Application.EnableEvents = True
    End Sub
  13. piti siinä fiksata toinenkin rivi...
    sarake A
    Set Alue = Range(ActiveCell, ActiveCell.Offset(0, 255).End(xlToLeft))

    sarake L
    Set Alue = Range(ActiveCell, ActiveCell.Offset(0, 244).End(xlToLeft))
  14. ohjeissa mainitsin
    oletuksena, että sarakkeessa A on tietoa...

    no fiksasin sen sarakkeelle L

    Sub PoistaTuplatRiviltä()
    Dim Solu As Range
    Dim Alue As Range
    On Error Resume Next

    Range("L3").Select
    Do Until ActiveCell = ""
    Set Alue = Range(ActiveCell, ActiveCell.Offset(0, 244).End(xlToLeft))
    For Each Solu In Alue
    If WorksheetFunction.CountIf(Alue, Solu) > 1 Then
    Solu.Clear
    End If
    Next Solu
    Alue.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
    ActiveCell.Offset(1, 0).Select
    Loop
    End Sub
  15. 3 solua malliksi...
    varmuuden vuoksi resetointikoodit jos mokaat...

    Sheet1 moduuliin....

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Target, Range("K5,K7,K9")) Is Nothing Then
    Select Case Target.Address
    Case "$K$5"
    Worksheets("Sheet2").Range("B11") = Target
    Case "$K$7"
    Worksheets("Sheet2").Range("B20") = Target
    Case "$K$9"
    Worksheets("Sheet2").Range("C29") = Target
    End Select
    End If
    Application.EnableEvents = True
    End Sub
    Sub Resetoi()
    Application.EnableEvents = True
    End Sub

    Sheet2 moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Target, Range("B11,B20,C29")) Is Nothing Then
    Select Case Target.Address
    Case "$B$11"
    Worksheets("Sheet1").Range("K5") = Target
    Case "$B$20"
    Worksheets("Sheet1").Range("K7") = Target
    Case "$C$29"
    Worksheets("Sheet1").Range("K9") = Target
    End Select
    End If
    Application.EnableEvents = True
    End Sub
    Sub Resetoi2()
    Application.EnableEvents = True
    End Sub
  16. mutta ei noilla lähtötiedoilla kannata alkaa koodaamaan...
    Tarkenna missä sarakkeessa kyssärit ja missä vastaukset yms.
  17. oletuksena, että sarakkeessa A on tietoa...

    moduuliin ...

    Sub PoistaTuplatRiviltä()
    Dim Solu As Range
    Dim Alue As Range
    On Error Resume Next

    Range("A1").Select
    Do Until ActiveCell = ""
    Set Alue = Range(ActiveCell, ActiveCell.Offset(0, 255).End(xlToLeft))
    For Each Solu In Alue
    If WorksheetFunction.CountIf(Alue, Solu) > 1 Then
    Solu.Clear
    End If
    Next Solu
    Alue.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
    ActiveCell.Offset(1, 0).Select
    Loop
    End Sub
  18. moduuliin...


    Sub LeikkaaJaSirrä()
    'leikkaa rivit 1-10000 uuteen taulukkoon Data1,Data2 jne
    'tiedot oletuksena Taulukossa Sheet1
    Sheets("Sheet1").Activate
    For i = 1 To 10
    Rows("1:10000").Cut
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Data" & i
    ActiveSheet.Paste
    Sheets("Sheet1").Activate
    Rows("1:10000").Delete Shift:=xlUp
    Next
    End Sub
  19. vanhoja yhdistäen ;-)

    moduuliin...

    Sub lajittele()
    Dim solu As Range
    Dim vika As Long
    Dim i As Long
    Dim EiTupla As New Collection
    Dim Löydetty As Range

    On Error GoTo virhe
    Vika = Range("E65536").End(xlUp).Row
    For Each solu In Range("E1:E" & Vika)
    If Not IsEmpty(solu) Then
    EiTupla.Add solu.Value, CStr(solu.Value)
    End If
    Next solu
    Range("F:G") = ""
    Range("F1").Select
    For i = 1 To EiTupla.Count
    ActiveCell = EiTupla(i)
    ActiveCell.Offset(1, 0).Select
    Next
    Columns("F:F").Sort Key1:=Range("F1"), Order1:=xlAscending
    Vika = Range("F65536").End(xlUp).Row
    For Each solu In Range("F1:F" & Vika)
    Set Löydetty = EtsiJaSiirrä(solu)
    solu.Offset(0, 1) = Löydetty.Cells.Count
    Next
    Exit Sub
    virhe:
    Resume Next
    End Sub


    Function EtsiJaSiirrä(Hakuehto As Variant) As Range
    Dim solu As Range
    Dim EkaOsoite As String
    Worksheets("Sheet1").Activate
    With Range("E:E")
    Set solu = .Find( _
    What:=Hakuehto, _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=False, _
    SearchFormat:=False)
    If Not solu Is Nothing Then
    Set EtsiJaSiirrä = solu
    EkaOsoite = solu.Address
    Do
    Set EtsiJaSiirrä = Union(EtsiJaSiirrä, solu)
    Set solu = .FindNext(solu)
    Loop While Not solu Is Nothing And solu.Address EkaOsoite
    End If
    End With
    End Function

    Keep Excelling
    @Kunde
  20. että homma toimii...
    Ko funktio on todella monipuolinen, mutta sehän perustuukin Range- objektiin, mikä on mitä monipuolisin objekti Excelin kirjastossa. Soveltamalla saa aikaiseksi uskomattomia juttuja parin rivin koodilla ...

    Tattista vaan
    Keep Excelling
    @Kunde
    21. 43 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt