kunde

kunde profiilikuva
Joulu 2024
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

Liittynyt 20v sitten
7 aloitusta · 1377 kommenttia
Uusimmat aloituksetSuosituimmat aloituksetUusimmat kommentit
Lisää ActiveX combobox ja suunnittelutilassa tuplaklikkaa komponenttiä ja VBA puolella ominaisuuksisssa(PROPERTIES)
ListRows =20 tai montako riviit haluut näkyville...
ListFillRange=alue mistä tiedot haetaan esim G1:G20
LinkedCell=A1 (B1 ja C1 muilla comboilla)

Keep EXCELing
@Kunde
En jaksa nyt alkaa sääteleen 15 riville... ;- )
Kuten olen jo monta kertaa maininnut koodi toimii soluille A1, B1 ja C1 ja niihin tein kelpoisuusehdon, josta valitaan siirrettävä tieto ja se siirretään napilla.
En edelleenkään ymmärrä, miksi pitäisi saada 15 riviltä siirrettyä, kun se hoituu 1 rivilläkin ja helpommin?

Keep EXCELing
@Kunde
tää foorumi lisää ylimääräisen rivinvaihdon koodiin

korjaa punaisena olevat rivit seuraavasti:
poista alaviiva ja siirrä kaikki yhdelle riville tyyliin

Function EtsiVika(MitäEtsitään As String, MistäEtsitään As String, MoneskoEsiintymä As Long) As Long

eli toi MoneskoEsiintymä As Long) As Long kanssa samalle riville...

Keep EXCELing
@Kunde
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
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
"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
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
Matriisikaava

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

Keep EXCELing
@Kunde
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...
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
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
Tematiikkavastaava>>>
unohtui mainita, että TAUL2:ssa
A1 henkilö
B1 paikka
C1 aika
ja koodi siirtää tiedot sitten Taul1


Keep EXCELing
@Kunde
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!!
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
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
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
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
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
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ä) ;-)
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
13 / 69
TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt