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

  1. Ei tartte edes kommentteja tehdä...

    Taul 2 moduuliin sille napille koodi...

    Private Sub CommandButton1_Click()
    EtsiJaSiirrä Worksheets("Taul2").Range("A1"), Worksheets("Taul1").Range("A:A")
    End Sub


    tavalliseen moduuliin...
    Module 1 koodit...

    Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Boolean

    Dim solu As Range
    Dim x As Long
    Dim y As Long
    Worksheets("Taul1").Activate
    EtsiJaSiirrä = False
    With HakuAlue

    Set solu = .Find(What:=Hakuehto, LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Not solu Is Nothing Then
    If solu.Comment Is Nothing Then
    solu.AddComment
    solu.Comment.Text Hakuehto & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1")
    Else

    x = Len(solu.Comment.Text) - Len(Application.WorksheetFunction.Substitute(solu.Comment.Text, Chr(13), "")) + 1
    If x < 4 Then
    solu.Comment.Text Worksheets("Taul2").Range("A1") & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1") & vbNewLine & Mid(solu.Comment.Text, InStr(1, solu.Comment.Text, Chr(13)) + 2)
    solu.Comment.Shape.TextFrame.AutoSize = True
    Else

    solu.Comment.Text Worksheets("Taul2").Range("A1") & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1") & vbNewLine & Mid(solu.Comment.Text, InStr(1, solu.Comment.Text, Chr(13)) + 2)
    y = EtsiVika(Chr(13), solu.Comment.Text, x - 1)
    solu.Comment.Text Mid(solu.Comment.Text, 1, y)
    solu.Comment.Shape.TextFrame.AutoSize = True
    End If

    End If
    EtsiJaSiirrä = True
    End If

    End With
    Worksheets("Taul2").Activate
    End Function

    Function EtsiVika(MitäEtsitään As String, _
    MistäEtsitään As String, MoneskoEsiintymä As Long) As Long
    Dim i As Integer
    Application.Volatile
    EtsiVika = 0
    For i = 1 To MoneskoEsiintymä
    EtsiVika = InStr(EtsiVika + 1, MistäEtsitään, MitäEtsitään)
    If EtsiVika = 0 Then Exit For
    Next
    End Function


    Keep EXCELing
    @Kunde
  2. Ei Taul2 vaan ...
    missä tahansa taulukon solussa ALT+F11
    sitten VBA editorin puolella valikosta INSERT/MODULE
    klikkaa oikealla tyhjää tilaa ja liitä koodi...
    VBAProject ikkunassa pitää olla valittuna Modules/Module1 oletuksena (sinisenä)valittuna kun koodin lisäät...

    Keep EXCELing
    @Kunde
  3. "Odotan mielenkiinnolla päivitystä koodille.
    Btw.. >>ei kovin helppoa muuten hallita.<<
    Tarkoititko, että koodin tekeminen on vaikeaa, vai että teen itse tuosta vaikean? :D"

    Jos solun arvot muuttuu ja se pitäsisi automatisoida niin helposti tulee virhelisäyksiä ja sitten niitä pitää mennä manuaalisesti poistelemaan...
    Toisaalta voisi laittaa koodin kysymyksen "oletko varma, että haluat..." , mutta tyhmää ;-)
    No napilla lisäät nyt, mitä olet kirjoittanut soluihin A1, B1 ja C1. Mielestäni järkevin tapa?

    alla tarkistettu toimiva koodi
    tavalliseen moduuliin..
    Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Boolean

    Dim solu As Range
    Dim x As Long
    Dim y As Long
    Worksheets("Taul1").Activate
    EtsiJaSiirrä = False
    With HakuAlue

    Set solu = .Find(What:=Hakuehto, LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Not solu Is Nothing Then
    If solu.Comment Is Nothing Then
    solu.AddComment
    solu.Comment.Text Hakuehto & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1")
    Else

    x = Len(solu.Comment.Text) - Len(Application.WorksheetFunction.Substitute(solu.Comment.Text, Chr(13), "")) + 1
    If x < 4 Then
    solu.Comment.Text Worksheets("Taul2").Range("A1") & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1") & vbNewLine & Mid(solu.Comment.Text, InStr(1, solu.Comment.Text, Chr(13)) + 2)
    solu.Comment.Shape.TextFrame.AutoSize = True
    Else

    solu.Comment.Text Worksheets("Taul2").Range("A1") & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1") & vbNewLine & Mid(solu.Comment.Text, InStr(1, solu.Comment.Text, Chr(13)) + 2)
    y = EtsiVika(Chr(13), solu.Comment.Text, x - 1)
    solu.Comment.Text Mid(solu.Comment.Text, 1, y)
    solu.Comment.Shape.TextFrame.AutoSize = True
    End If

    End If
    EtsiJaSiirrä = True
    End If

    End With
    Worksheets("Taul2").Activate
    End Function

    Function EtsiVika(MitäEtsitään As String, _
    MistäEtsitään As String, MoneskoEsiintymä As Long) As Long
    Dim i As Integer
    Application.Volatile
    EtsiVika = 0
    For i = 1 To MoneskoEsiintymä
    EtsiVika = InStr(EtsiVika + 1, MistäEtsitään, MitäEtsitään)
    If EtsiVika = 0 Then Exit For
    Next
    End Function

    Keep EXCELing
    @Kunde
  4. Monille tuottaa vaikeuksia ymmärtää matriisikaavoilla laskeminen ja miten kaava toimii.
    Kaavan laskentaa voi tutkia esim. klikkaamalla kaavasolua ja sitten valikosta KAAVAT/LASKE KAAVA. Avautuvaan lomakkeeseen tulee kaava ja siinä voi tsekata laskemisen etenemistä askel askeleelta.
    Yksittäisen kaavan tulosta voi tutkia kaavarivillä maalaamalla kaavan argumentteineen ja näppikseltä F9, jolloin laskettu kaavantulos näkyy. ESC näppiksellä palataan takaisin kaavan alkuperäiseen muotoon ei ENTERIÄ tässäkohtaa!!!

    Käydäänpäs sitten läpi kaavan laskemisen logiikka esimerkkitapauksessa.
    Oletetaan että D1:D3 on A,B,C ja E1:E3 on 1,2,3 ja F1:F3 soluissa on ykköset muut alueen solut tyhjiä...

    =KESKIARVO(JOS(F1:F10=1;JOS(1-ONVIRHE(VASTINE(D1:D10;{"A";"B";"C"};0));E1:E10)))

    esim. kaavassa ensiksi testataan alueen F1:F10 ykköset
    F1:F10=1
    ja tulokseksi saadaan matriisi
    {TOSI;TOSI;TOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI}
    eli F1:F3:ssa on ykköset =TOSI

    seuraavaksi lasketaan
    VASTINE(D1:D10;{"A";"B";"C"};0)
    eli tutkitaan löytyykö alueelta D1:D10 soluissa arvot A tai B tai C ja tulokseksi tulee jos solun arvo on A-1 ja B-2 ja C-3, eli kirjaimen suhteellinen sijainti matriisissa {"A";"B";"C"}

    {1;2;3;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!}

    tässä kohtaa nimimerkillä MATRIISI meni sormi suuhun...
    eli seuraavaksi pitäisi poistaa virheet...

    ONVIRHE(VASTINE(D1:D10;{"A";"B";"C"};0)

    ONVIRHE({1;2;3;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!;#PUUTTUU!})

    {EPÄTOSI;EPÄTOSI;EPÄTOSI;TOSI;EPÄTOSI;TOSI;TOSI;EPÄTOSI;TOSI;TOSI}

    nyt meillä onkin virheetön matriisi, mutta arvot ovat juuri päinvastoin, eli TOSI=EPÄTOSI jA EPÄTOSI=TOSI eli meidän pitää seuraavaksi muuntaa ne käänteiseksi

    1-ONVIRHE(VASTINE(D1:D10;{"A";"B";"C"};0))

    tällä kätevällä tavalla se hoituu, koska TOSI=1 ja EPÄTOSI=0
    eli jos TOSI niin 1-1=O eli tulokseksi tulee EPÄTOSI=0...

    {1;1;1;0;0;0;0;;0;0}

    seuraavaksi kerrotaan jälkimmäisen jos- lausekkeen matriisit keskenään
    JOS(1-ONVIRHE(VASTINE(D1:D10;{"A";"B";"C"};0));E1:E10)

    E1:E10={1;2;3;0;0;0;0;0;0;0}

    JOS({1;1;1;0;0;0;0;;0;0}*{1;2;3;0;0;0;0;0;0;0})
    {1;2;3;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI}

    seuraavaksi ensimmäinen jossin matriisit kerrotaan keskenään
    JOS(F1:F10=1;JOS(1-ONVIRHE(VASTINE(D1:D10;{"A";"B";"C"};0));E1:E10))

    JOS({TOSI;TOSI;TOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI}*{1;2;3;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI})

    ja tulokseksi tulee
    {1;2;3;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI}

    ja lopuksi sitten keskiarvo matriisista

    KESKIARVO(JOS(F1:F10=1;JOS(1-ONVIRHE(VASTINE(D1:D10;{"A";"B";"C"};0));E1:E10)))

    KESKIARVO({1;2;3;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI;EPÄTOSI})
    ja tulokseksi 2

    ehkäpä tämä selvitys helpotti ymmärtämään kaavan rakenne ;-)

    Keep EXCELing
    @Kunde
  5. Matriisikaava

    =(KESKIARVO((JOS(F1:F10=1;JOS(1-ONVIRHE(VASTINE(D1:D10;{"A";"B";"C"};0));E1:E10)))))

    Keep EXCELing
    @Kunde
  6. Ajattelin, että soluissa A1 ja B1 on kelpoisuusehdot ja alasvetovalikosta valitaan tiedot soluihin A1 ja B1 ja C1 kirjoitetaan aika ja napilla lisätään, ei kovin helppoa muuten hallita.
    Tsekkaan ehtoolla ton koodin. Uusin oli tarkoitus olla ylinnä ja lokia pitää halutun rivien verran muuttujan arvoa muuttamalla...
  7. VBA editorin puolella valikosta INSERT/MODULE ja sinne proseduuri Function EtsiJaSiirrä(...)

    ja napin koodi Taul2 moduuliin eli kuten kirjoititkin. Ja teet Taul2 ActiveX painikkeen ja jätät sen oletusnimelle eli CommandButton1.
    Kun Klikkaat nappia se suorittaa sitten koodin

    Private Sub CommandButton1_Click()
    EtsiJaSiirrä Worksheets("Taul2").Range("A1"), Worksheets("Taul1").Range("A:A")
    End Sub

    ja toi suorittaa sitten EtsiJaSiirrä koodin tavallisessa moduulissa...

    nyt siis Taul2
    A1 = nimi
    B1 =paikka
    C1=aika
    ja nappi joka suorittaa koodin

    ja Taul1 A-sarakkeessa on nimisolut, joiden kommentteihin kirjoitetaan.
    Muuta koodissa lokin rivien määrää muuttamalla x:n ehtoa

    esim. 20 riviä
    If x < 21 Then


    Keep EXCELing
    @Kunde
  8. jäi napinkin koodi pois näköjään...

    eli tavalliseen moduuliin tämä...

    Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Boolean

    Dim solu As Range
    Worksheets("Taul1").Activate
    EtsiJaSiirrä = False
    With HakuAlue

    Set solu = .Find(What:=Hakuehto, LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Not solu Is Nothing Then
    If solu.Comment Is Nothing Then
    solu.AddComment
    solu.Comment.Text Hakuehto & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1")
    Else

    x = Len(solu.Comment.Text) - Len(Application.WorksheetFunction.Substitute(solu.Comment.Text, vbCrLf, ""))
    'tähän 1 enemmän kuin haluat riviä näytettävän
    If x < 5 Then
    solu.Comment.Text solu.Comment.Text & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1")
    Else
    solu.Comment.Text Worksheets("Taul2").Range("A1") & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1") & vbNewLine & Mid(solu.Comment.Text, InStr(1, Range("A2").Comment.Text, vbCrLf) + 2)
    End If

    End If
    EtsiJaSiirrä = True
    End If

    End With
    Worksheets("Taul2").Activate
    End Function


    ja Taul2 nappiin tämä koodi...

    Private Sub CommandButton1_Click()
    EtsiJaSiirrä Worksheets("Taul2").Range("A1"), Worksheets("Taul1").Range("A:A")
    End Sub


    Keep EXCELing
    @Kunde
  9. Tematiikkavastaava>>>
    unohtui mainita, että TAUL2:ssa
    A1 henkilö
    B1 paikka
    C1 aika
    ja koodi siirtää tiedot sitten Taul1


    Keep EXCELing
    @Kunde
  10. tuotenikkari>>>
    haluatko kuvat tiedostosta vaiko työkirjalta?

    Tematiikkavastaava>>>

    tavalliseen moduuliin...

    Function EtsiJaSiirrä(Hakuehto As Variant, HakuAlue As Range) As Boolean

    Dim solu As Range

    Dim EkaOsoite As String
    Worksheets("Taul1").Activate
    EtsiJaSiirrä = False
    With HakuAlue

    Set solu = .Find(What:=Hakuehto, LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Not solu Is Nothing Then
    If solu.Comment Is Nothing Then
    solu.AddComment
    solu.Comment.Text Hakuehto & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1")
    Else

    x = Len(solu.Comment.Text) - Len(Application.WorksheetFunction.Substitute(solu.Comment.Text, vbCrLf, ""))
    'tähän 1 enemmän kuin haluat riviä näytettävän
    If x < 5 Then
    Else
    solu.Comment.Text Worksheets("Taul2").Range("A1") & ":" & vbNewLine & Worksheets("Taul2").Range("B1") & " " & Worksheets("Taul2").Range("C1") & vbNewLine & Mid(solu.Comment.Text, InStr(1, Range("A2").Comment.Text, vbCrLf) + 2)
    End If

    End If
    EtsiJaSiirrä = True
    End If

    End With
    Worksheets("Taul2").Activate
    End Function

    ja liitä koodi vaikka ActiveX nappiin TAUL2:ssa


    KEEP NEW YEARING
    @Kunde

    P.S. Ilmottautukaa kurssille http://keskustelu.suomi24.fi/t/13999713/vba-kurssi
    ei mitään makronauhoituksia ja p****n jauhantaa 2 pv vaan tosi ACTIONIA n 40 tuntia!!
  11. jos haluat muuttaa kommentin muotoa...
    lisää allaoleva rivi With-End With lausekkeen sisälle ( poista = msoShapeBalloon teksti ja kirjoita = -merkki , niin avautuu alasvetovalikko eri muodoille...)
    .AutoShapeType = msoShapeBalloon

    jos haluat kuvan niin sekin onnaa, mutta vaatii hiukan lisäkoodia ;-)

    Keep EXCELing
    @Kunde
  12. kyllä ne siellä on, kunhan osaa etsiä oikeasta paikasta... ;-)

    luultavasti toi Autoshape=true riittää sulle?
    Jos ei niin hipsaa se rivi ja poista hipsut seuraavilta 3 riviltä ja muuta mitat sopiviksi, mutta luulen, että toi eka on parempi vaihtoehto.

    Huomaa pikku muutos With -End With rakenteessa
    ennen oli With Target.Comment.Shape.TextFrame
    nyt With Target.Comment.Shape


    If Target.Comment Is Nothing Then Target.AddComment
    'Application.UserName = "Kunde"
    Target.Comment.Text Application.UserName & ":" & vbNewLine & Worksheets("Taul2").Range("C2").Text
    With Target.Comment.Shape
    Dim Pituus As Long
    Pituus = Len(Application.UserName) + 1
    .TextFrame.Characters(1, Pituus).Font.ColorIndex = 3
    .TextFrame.Characters(1, Pituus).Font.Bold = True
    .TextFrame.AutoSize = True
    '.TextFrame.AutoSize = false
    '.Width = 100
    '.Height = 300
    End With
    ThisWorkbook.Save
    End If

    Keep EXCELing
    @Kunde
  13. Itse ajattelin vanhasta kokemuksesta seuraavaa:
    2 x vko 2 h opetusta ja viikon etätehtävien tehtäväselvitykset= 4h
    1 x vko 2 h etäduunia matskujen perusteella=2h (todennäköistä, että menee kauemmin... ;-) )
    yhteensä siis 6 h/ vko ja 6-7 viikkoa siis kurssi kestäisi. Jokaisella osallistujalla on tulee olla oma keksitty tai olemassaoleva projekti, jota osallistuja yrittää ratkoa kurssin matskun ja opetuksen perusteella, jonka siis räätälöin osallistujen kesken. Tarkoitus ei ole antaa suoraan valmiita koodeja projekteihin vaan vihjeitä ja ohjeita koodeilla, mutta jos osallistuja ei saa ratkaistua ongelmaansa, niin sitten yritetään muiden osallistujen kesken ratkoa ja jos ei onnistu, niin sitten Kunde jeesaa lopuksi(toivottavasti ei liian hevejä projekteja...)
    Eli ryhmässä vahvuus.
    Tossa lyhykäisyydessään kurssin tavoite.

    Toisaalta kurssilla tullaan tarvitsemaan tietoa Excelin tehokäytöstä (matriisifunktiot yms!) ja harjoituksia tehdään myös pelkillä kaavoilla vertailun vuoksi ja muistaakseni kaikkeahan ei voinut tehdä VBA:llakaan vai muistinko väärin? ;-)

    Edellä olevat voisivat kirjoitella samoilla nickeillään toiveistaan kurssin sisällöstä ja projektistaan www.kundepuu.com (vaatii rekisteräitymisen ) VBA- kurssi topiciin
    samoin kuin uudetkin kiinnostuneet...

    Keep EXCELing
    @Kunde
  14. muuta Taul1 koodissa ...

    nyt käyttäjän nimi boldattuna ja punaisella
    hipsaa With... - End With jos et tartte ominaisuuksia...
    Käyttäjän nimen voit vaihtaa Tiedosto/Asetukset/Yleiset ja siellä kirjoitat Käyttäjänimeen haluamaasi nimen tai sitten lisäät koodissa poistamalla hipsun

    If Target.Comment Is Nothing Then Target.AddComment
    'Application.UserName = "Kunde"
    Target.Comment.Text Application.UserName & ":" & vbNewLine & Worksheets("Taul2").Range("C2").Text

    With Target.Comment.Shape.TextFrame
    Dim Pituus As Long
    Pituus = Len(Application.UserName) + 1
    .Characters(1, Pituus).Font.ColorIndex = 3
    .Characters(1, Pituus).Font.Bold = True
    End With
    ThisWorkbook.Save
    End If

    "Sinun versiossa koodi ei hyödynnä väliin jääviä tyhjiä rivejä, vaan jatkaa vain järjestyksessä alaspäin. Käsitinkö tämän oikein?"

    ET, kyllä se täyttää ihan järjestyksessä ylhäältä alaspäin ekaan tyhjään soluun. Hieman ekstratarkistuksia jouduin tekemään, jos sattuisi olemaan täysin tyhjä A- sarake, kun aloittaa ja en tiennyt onko esim. A1 solussa tekstiä vaiko ei.
    Jos on niin sitten turhia tarkistuksi...


    Mitä tarkoittaa käytännössä tuo "looppien määrä kasvaa rivimäärän kasvaessa"? Pystyykö sen kumoamaan tuossa "Tämmösen" koodissa?

    For i = 1 To 200
    If Worksheets("Taul1").Cells(i, 1) = "" Then
    Worksheets("Taul1").Cells(i, 1) = Target.Value
    Exit Sub
    End If
    Next i

    eli jos eka tyhjä olisikin vasta A200, niin ollaan luupattu 199 kertaa... ja jos isompi rivimäärä eka tyhjä olisi vaikka A100000 niin olisi luupattu 99999 kertaa ennenkuin tyhjä solu on löydetty

    oma koodini ei luuppaa ;-)
    ja ei voi kumota tolla rakenteella luuppien määrää (for- next)

    Keep EXCELing
    @Kunde
  15. oli jostai syystä rivimäärä lipsahtunut 2300, oikea siis 200

    siirtotaulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Application.Intersect(Target, Range("A2")) Is Nothing Then

    If Worksheets("Taul1").Range("A2").End(xlDown).Row >=200 And Worksheets("Taul1").Range("A65536").End(xlUp).Row >= 200 Then

    MsgBox "Ei tyhjiä soluja!!!"

    Else

    If Worksheets("Taul1").Range("A65536").End(xlUp).Row < 2 Then

    Worksheets("Taul1").Range("A2") = Target

    Else

    If Worksheets("Taul1").Range("A65536").End(xlUp).Row < 3 Then

    Worksheets("Taul1").Range("A1").End(xlDown).Offset(1).Value = Target.Value

    Else

    Worksheets("Taul1").Range("A2").End(xlDown).Offset(1, 0) = Target.Value

    End If

    End If

    End If

    End If

    End Sub

    Keep EXCELing
    @Kunde
  16. Taul1 moduuliin ja varmista , ettei ole jo samannimistä proseduuriaennestään

    Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next

    Application.EnableEvents = False

    If Not Intersect(Target, Range("A2:A200")) Is Nothing Then

    If Not Target = "" Then

    Range("G" & Target.Row) = Now()
    'muuta soluosoitetta tarvittaessa
    'jos muualle kuin A sarakkeeseen käytä target.Offset (0,XXX) solun osoitteena. Muista että offset on 0-pohjainen
    If Target.Comment Is Nothing Then Target.AddComment
    Target.Comment.Text Worksheets("Taul2").Range("C2").Text

    ThisWorkbook.Save

    End If

    End If

    If Not Intersect(Target, Range("B2:I200")) Is Nothing Then

    If Not Intersect(Target, Range("I2:I200")) Is Nothing Then

    If Not Target = "" And Not Range("A" & Target.Row) = "" Then

    Range("H" & Target.Row) = Now()

    Range("J" & Target.Row) = "PÄIVITÄ"

    Else

    ' hipsaa seuraava rivi, jos et halua, että I- sarakkeen solu tyhjenee hutitilanteessa

    Target = ""

    End If

    End If

    End If

    If Not Intersect(Target, Range("J2:J200")) Is Nothing Then

    If Target = "PÄIVITÄ" Then

    Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)

    Range("A" & Target.Row & ":I" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)

    Target = ""

    Range("I" & Target.Row) = ""

    Range("H" & Target.Row) = ""

    Range("A" & Target.Row) = ""

    Range("G" & Target.Row) = ""

    Range("B" & Target.Row) = ""

    Range("C" & Target.Row) = ""

    Range("D" & Target.Row) = ""

    Range("E" & Target.Row) = ""

    Range("F" & Target.Row) = ""

    Range("A" & Target.Row).Comment.Delete

    End If

    End If

    Application.EnableEvents = True

    End Sub
    Sub Resetoi()
    Application.EnableEvents = True
    End Sub
    ************************************************************
    siirtotaulukon moduuliin...

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Application.Intersect(Target, Range("A2")) Is Nothing Then
    If Worksheets("Taul1").Range("A2").End(xlDown).Row >=2300 And Worksheets("Taul1").Range("A65536").End(xlUp).Row >= 200 Then
    MsgBox "Ei tyhjiä soluja!!!"
    Else
    If Worksheets("Taul1").Range("A65536").End(xlUp).Row < 2 Then
    Worksheets("Taul1").Range("A2") = Target
    Else
    If Worksheets("Taul1").Range("A65536").End(xlUp).Row < 3 Then
    Worksheets("Taul1").Range("A1").End(xlDown).Offset(1).Value = Target.Value
    Else
    Worksheets("Taul1").Range("A2").End(xlDown).Offset(1, 0) = Target.Value
    End If
    End If
    End If
    End If
    End Sub


    jälkimmäisen voi korvata toki Tämmöisen koodillakin( en testannut, mutta ilmeisesti toimii), mutta siinä looppien määrä kasvaa rivimäärän kasvaessa, joten tehokkuus kärsii (ei tosin nyt merkittävästi vielä 200 rivillä) ;-)
  17. Kirjoita koodieditorissa
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
    :=False, Transpose:=True

    kaikki yhdelle riville pötköön ja poista alaviiva merkki ( _ ) koodiriviltä ( helpoin tapa fiksata aloittelijan)

    Keep EXCELing
    @Kunde
  18. Ilmeisesti sulla oli saman taulukon koodissa 2 saman nimistä proseduuria?
  19. Piece of cake
    arvatenkin haluat sieltä Taul2 jostain solusta lisätä johonkin Taul1 soluun hakemasia tietoja. Entä jos on jo tietoa solun kommentissa - poistetaanko vaiko lisätään perään?


    Keep EXCELing
    @Kunde
  20. Mitähän sääntöjen vastaista mun vastauksessa mahtoi olla???
    21. 13 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt