kunde
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 sitten
Muokkaa profiilia7 aloitusta · 1377 kommenttia
- 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