Varastohistorian luominen

Kävin Kunden sivulla.. aika kova etsiminen. En toistaiseksi löytänyt osumaa aiheesta. Kiitos osoitteesta.

Makroa ei pidä laitaa moduliin, vaan se on kyseisen sivun koodia.

Makrot, jotka tarkkailevat taulun tapahtumia, pitää liittää ko. tauluun. Modulissa eivät toimi. Ne funktiot ja makrot, joita on tarkoitus kutsua tauluista tai moduleista pitää olla moduleissa. Taulun koodisivulta niitä ei voi kutsua.

Tekeekö tuo makro sinulla yhtään mitään? Joskus Excel menee jumiin, eikä mikään tunnu toimivan. Näin käy esim. silloin kun yo. makro ei mene loppuun. Silloin auttaa, kun ajaa seuraavan moduliin kirjoitetun makron.

Sub Enable()
Application.EnableEvents = True
End Sub

Worksheets("Taul2").Rows(2).Insert
Worksheets("Taul2").Range("A2:B2") = Range("A1:B1").Value
.

Tämmöinen kirjoitti:

Worksheets("Taul2").Rows(2).Insert
Worksheets("Taul2").Range("A2:B2") = Range("A1:B1").Value
.

Mainiota. Kiitos!
Lisäkysymys aiheeseen:
Saamani apu on liittynyt Tau1 (A1:B1) solujen tiedon kopioitumiseen => Taul2 (A2:B2):een.
Miten onnistuu kopioida Taul1 (A2:B2) solujen tieto => Taul2 (A2:B2) :een, samassa VB koodissa?
Jatkossa osaan kopsata Taul1 (A3:B3)...jne aina (A500:B500) asti tarvittaessa.

Riittoa kirjoitti:

Mainiota. Kiitos!
Lisäkysymys aiheeseen:
Saamani apu on liittynyt Tau1 (A1:B1) solujen tiedon kopioitumiseen => Taul2 (A2:B2):een.
Miten onnistuu kopioida Taul1 (A2:B2) solujen tieto => Taul2 (A2:B2) :een, samassa VB koodissa?
Jatkossa osaan kopsata Taul1 (A3:B3)...jne aina (A500:B500) asti tarvittaessa.

Lue lisää

Korjaus:
Siis Miten onnistuu kopioida Taul1 (A2:B2) solujen tieto => Taul2 (A3:B3) :een, samassa VB koodissa?

Tämmöinen kirjoitti:

Worksheets("Taul2").Rows(2).Insert
Worksheets("Taul2").Range("A2:B2") = Range("A1:B1").Value
.

HUHTIKUUN HULINAT -15% ALENNUSTA

ostostesi loppusummasta WWW.KIRJAONLINE.COM verkkokaupasta.

Tarjous voimassa 1.4.15-30.4.15

ALENNUKSEN SAAT koodilla 042015

Tarkemmat ohjeet: http://www.kirjaonline.com/news/9/15-ale-huhtikuun-ajan

http://www.kirjaonline.com/product/871/jeesus-on

Judah Smith esittelee meille Jeesuksen, jota synkät maalaukset ja virret eivät ole onnistuneet kuvaamaan. Innoissaan, humoristisesti ja vakuuttavasti hän osoittaa, että Jeesus elää. Jeesus on armo. Jeesus on ystävämme. Jeesus on uusi, parempi tapa olla ihminen.

Pois kaikki muut ajatukset......†

Tuputin_huono

Tämä kopioi minkä tahansa sarakkeen ensimmäisellä rivillä tehdyn muutoksen toiselle sivulle. Jos täytyy pitää kirjaa muiden rivien muutoksista, pitää päättää, minne ne talletetaan. Jos sarakemäärä rajoitetaan vaikka kymmeneen, voisi kakkosrivin muutokset tallettaa esim. sarakkeisiin 11-20, kolmosrivi 21-30 jne.

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Err

   Application.EnableEvents = False

   If Target.Row = 1 Then
      C = Target.Column
      Worksheets("Sheet2").Cells(2, C).Insert Shift:=xlDown
      Worksheets("Sheet2").Cells(2, C) = Target.Value
   End If

Err:
   Application.EnableEvents = True
End Sub

Voihan sen muutoksen kirjata toiseen taulukkoon lokityyliin yksinkertaisesti vaikka näin sarakkeeseen H
"Solun A1 arvo muutui arvosta 2 arvoon 3 8.3.2015 klo 8:33
"Solun D3 arvo muutui arvosta 2 arvoon 10 8.3.2015 klo 8:34
ja kopsataan aina muuttunutta riviä "varmuuskopioon"

tai sitten hiukan hevimpi vaihtoehto...
no katotaan miten ketju etenee ;-)

Tämmöinen kirjoitti:

Tämä kopioi minkä tahansa sarakkeen ensimmäisellä rivillä tehdyn muutoksen toiselle sivulle. Jos täytyy pitää kirjaa muiden rivien muutoksista, pitää päättää, minne ne talletetaan. Jos sarakemäärä rajoitetaan vaikka kymmeneen, voisi kakkosrivin muutokset tallettaa esim. sarakkeisiin 11-20, kolmosrivi 21-30 jne.

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Err

   Application.EnableEvents = False

   If Target.Row = 1 Then
      C = Target.Column
      Worksheets("Sheet2").Cells(2, C).Insert Shift:=xlDown
      Worksheets("Sheet2").Cells(2, C) = Target.Value
   End If

Err:
   Application.EnableEvents = True
End Sub

Lue lisää

"Tämmöinen", Mitenköhän tuossa laittamassasi VB -koodissa nuo: "Jos sarakemäärä rajoitetaan vaikka kymmeneen, voisi kakkosrivin muutokset tallettaa esim. sarakkeisiin 11-20, kolmosrivi 21-30 jne." ilmenisivät, eli missä kohtaa koodia ne olisivat, jotta niitä voisi itse hieman modailla sopiviksi? Tuo oli ihan mainio ajatus jaksottaa 10-riveihin peräkkäin nuo muutokset.

Kundepuu kirjoitti:

Voihan sen muutoksen kirjata toiseen taulukkoon lokityyliin yksinkertaisesti vaikka näin sarakkeeseen H
"Solun A1 arvo muutui arvosta 2 arvoon 3 8.3.2015 klo 8:33
"Solun D3 arvo muutui arvosta 2 arvoon 10 8.3.2015 klo 8:34
ja kopsataan aina muuttunutta riviä "varmuuskopioon"

tai sitten hiukan hevimpi vaihtoehto...
no katotaan miten ketju etenee ;-)

Lue lisää

Kundepuu, Miten ja mihin kohtaa valmista koodia ehdottamasi rivit tulisi. Olen hieman huono VB:ssä, mutta en onneton.. Kuulostaa tuo "hevimpi" vaihtoehto kiinnostavalta. Mitähän se olisi? :)

Grouzet kirjoitti:

"Tämmöinen", Mitenköhän tuossa laittamassasi VB -koodissa nuo: "Jos sarakemäärä rajoitetaan vaikka kymmeneen, voisi kakkosrivin muutokset tallettaa esim. sarakkeisiin 11-20, kolmosrivi 21-30 jne." ilmenisivät, eli missä kohtaa koodia ne olisivat, jotta niitä voisi itse hieman modailla sopiviksi? Tuo oli ihan mainio ajatus jaksottaa 10-riveihin peräkkäin nuo muutokset.

Lue lisää

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Err

   Application.EnableEvents = False

   R = Target.Row
   C = Target.Column
   If C <= 10 Then
      With Worksheets("Sheet2")
         .Cells(2, C (R - 1) * 10).Insert Shift:=xlDown
         .Cells(2, C (R - 1) * 10) = Target.Value
      End With
   End If
Err:

   Application.EnableEvents = True

End Sub

Yllä oleva ratkaisu näytti vähän sekavalta. Kunden ehdottama loki on parempi. Siinä yksi asia per sarake on mielestäni selkeämpi kuin saman kertominen virkkeessä. Ainakin lokin tietojen hyödyntäminen on helpompaa.

Tässä loki tulostuu neljälle sarakkeelle A-D: Aika, Muutettu solu, Vanha arvo ja Uusi arvo. Se täyttyy aikajärjestyksessä, tässä viimeisin tapahtuma alimmaisena. Jos With-lauseen neljä riviä korvataan kommentiksi merkityillä, viimeisin tapahtuma tulee ylimmäiseksi riville 2.

===== Moduli:

Global Entinen As Variant
Global Vanha As Variant

===== ThisWorkbook:

Private Sub Workbook_Open()
   Entinen = ActiveCell.Value
   Vanha = ActiveCell.Value
End Sub

===== Sivun koodi:

Private Sub Worksheet_Activate()
   Entinen = ActiveCell.Value
   Vanha = ActiveCell.Value
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Vanha = Entinen
   Entinen = Target.Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Err

   Application.EnableEvents = False

   C = Target.Column
   R = Sheets("Sheet2").Cells(65536, 1).End(xlUp).Row 1
   With Worksheets("Sheet2")
      '.Rows(2).Insert Shift:=xlDown
      '.Cells(2, 1) = Now()
      '.Cells(2, 2) = Target.Address
      '.Cells(2, 3) = Vanha
      '.Cells(2, 4) = Target.Value
      .Cells(R, 1) = Now()
      .Cells(R, 2) = Target.Address
      .Cells(R, 3) = Vanha
      .Cells(R, 4) = Target.Value
   End With

Err:
   Application.EnableEvents = True

End Sub

Tämmöinen kirjoitti:

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Err

   Application.EnableEvents = False

   R = Target.Row
   C = Target.Column
   If C <= 10 Then
      With Worksheets("Sheet2")
         .Cells(2, C (R - 1) * 10).Insert Shift:=xlDown
         .Cells(2, C (R - 1) * 10) = Target.Value
      End With
   End If
Err:

   Application.EnableEvents = True

End Sub

Yllä oleva ratkaisu näytti vähän sekavalta. Kunden ehdottama loki on parempi. Siinä yksi asia per sarake on mielestäni selkeämpi kuin saman kertominen virkkeessä. Ainakin lokin tietojen hyödyntäminen on helpompaa.

Tässä loki tulostuu neljälle sarakkeelle A-D: Aika, Muutettu solu, Vanha arvo ja Uusi arvo. Se täyttyy aikajärjestyksessä, tässä viimeisin tapahtuma alimmaisena. Jos With-lauseen neljä riviä korvataan kommentiksi merkityillä, viimeisin tapahtuma tulee ylimmäiseksi riville 2.

===== Moduli:

Global Entinen As Variant
Global Vanha As Variant

===== ThisWorkbook:

Private Sub Workbook_Open()
   Entinen = ActiveCell.Value
   Vanha = ActiveCell.Value
End Sub

===== Sivun koodi:

Private Sub Worksheet_Activate()
   Entinen = ActiveCell.Value
   Vanha = ActiveCell.Value
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Vanha = Entinen
   Entinen = Target.Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Err

   Application.EnableEvents = False

   C = Target.Column
   R = Sheets("Sheet2").Cells(65536, 1).End(xlUp).Row 1
   With Worksheets("Sheet2")
      '.Rows(2).Insert Shift:=xlDown
      '.Cells(2, 1) = Now()
      '.Cells(2, 2) = Target.Address
      '.Cells(2, 3) = Vanha
      '.Cells(2, 4) = Target.Value
      .Cells(R, 1) = Now()
      .Cells(R, 2) = Target.Address
      .Cells(R, 3) = Vanha
      .Cells(R, 4) = Target.Value
   End With

Err:
   Application.EnableEvents = True

End Sub

Lue lisää

Meni hieman ohi tuo viimeisin postaus. En osaa kaikkea tuota sijoittaa/hyödyntää tarpeisiini, taitavat olla eri variaatioita tai vaihtoehtoisia koodirivejä johonkin väliin peruskoodistoa.

Oma tarpeeni tällä idealla olisi hyvin simppeli, eli täällä esitettyjä ideoita hyödyntäen seuraava:
Taul1
(A1-E1) pysyvät tiedot, eli ne ei muutu
(A2-E2) soluissa vaihtuva tieto
(A3-E3) soluissa vaihtuva tieto
(A4-E4) soluissa vaihtuva tieto
...
...
...
(A100-E100) soluissa vaihtuu tieto

Jokaisesta Taul1:n rivistä tallentuisi Taul2:een oma max.5:n rivin lokihistoria. Alla ajatus:
Taul1 => Taul2
Rivi 2 => 1-5
Rivi 3 => 6-10
Rivi 4 => 11-15
Rivi 5 => 16-20
Rivi 6 => 21-25
Rivi 7 => 26-30
...
..
..
jne

Aukesikohan guruille. :)

moduuliin...
aja makro ekaksi

Sub teeVarmuuskopio()
Dim Nimi As Name
Dim Rivi As Long
Dim Rivi2 As Long
Dim Rivi3 As Long
'muuta taulukon nimi sopivaksi
With Worksheets("Sheet2")
.Range("A:E") = ""
.Activate
For Each Nimi In ActiveWorkbook.Names
Nimi.Delete
Next
End With

Rivi = 2
Rivi2 = 6
Rivi3 = 1

For i = 1 To 100
'muuta taulukon nimi ja työkirjan nimetyn alueen nimi sopivaksi ja muuta rivienmäärää
Worksheets("Sheet2").Names.Add Name:="Rivi" & Rivi3, RefersToR1C1:="=Sheet2!R" & Rivi & "C1:R" & Rivi2 & "C5"
Rivi = Rivi 5
Rivi2 = Rivi2 5
Rivi3 = Rivi3 1
Next

Rivi = 2
Rivi2 = 6
For Each solu In Worksheets("Sheet1").Range("A2:A100")
solu.EntireRow.Copy Worksheets("Sheet2").Range("A" & Rivi)
Rivi = Rivi 5
Rivi2 = Rivi2 5
Next
End Sub

ko. taulukon moduuliin...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A2:E100")) Is Nothing Then
Worksheets("Sheet2").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Sheet2").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":E" & Target.Row).Copy Worksheets("Sheet2").Range("Rivi" & Target.Row - 1).Resize(1)
End If
End Sub


Keep EXCELing
@Kunde

Tämä on mahtavaa, kun täältä saa asialle omistautuneilta arvokkaita neuvoja.
Kundelle erityinen kiitos kattavan näköisestä avusta.
Teen varmasti jotain väärin, kun en saa koodia taipumaan tahtooni.
Tämän saan onnistumaan:
Kun kirjoitan tietoa (Sheet1) riveille 1-100 tulee ne (Sheet2) riveille 1, 6, 11, 16, 21, 26...jne klikkaamalla VB:n makro-nuolenkärkeä. Tähän kaikki tyssää.

Tätä en saa toimimaan:
1. En saa makroa toimimaan (rivinvaihto)enteriä painamalla (varmaan joku tallennusjuttu..)
2. Esim. Sheet1 riville 2 tekemät muutokset eivät keräänny/tallennu lokimaisesti Sheet2 riveille 1-5, eli viisi edellistä tapahtumaa.

Ihan varmasti jotain jää mulla huomioimatta.

eka makro tavalliseen moduuliin ja suorita se kerran.
Se tyhjentää Sheet2 sarakkeet A:E ja poistaat nimetyt alueet ja lisää uudet lisätyt alueet rivi1, rivi2 jne. ja kopioida Sheet1 rivi2 Sheet2 riville 2 ja Sheet1 rivi3 Sheet2 riville 6 jne...

toka makro Sheet1 taulukon moduuliin
ko. taulukon moduuliin...
Sitten kun muutat arvoja alueella A2:E100 nii kopioi oikealle riville ja siirtää edelliset arvot alaspäin, eli 5 viimeistä runnaa jatkuvasti...

Keep EXCELing
@Kunde

Huomasin jännän "epätoivotun" ilmiön Kunden tekemässä muuten niin hienossa koodissa..
Kun muutan esim. vain yhden solun tietoa (Sheet1 A2-E2 rivillä), kopioituu koko rivi (A2-E2) Sheet2:lle määrätylle alueelle. Tämähän olikin tietty alkuperäinen ajatus, vaikkakaan ei loppuun asti ajateltu.
Onko mahdollista käynnistää makro esim. nappia painamalla _vasta_ sitten kun kaikki halutut solut on muutettu ko. rivillä?

tottakai ;-)

Keep EXCELing
@kunde

Hehh.. rehellinen vastaus.. ;D
Muotoilen toiveeni uudelleen; Minkälainen olisi ratkaisu yo. "onkelmaan"? Kokeilun ja erehdysten kautta voisin jopa onnistua tekemään tuosta karvalakkimallisen makron käynnistämisen, mutta aina se hiotumpikin ratkaisu kelpaisi. :))

Poista taukokon moduulista Worksheet_Change koodi ja lisää allaoleva tavalliseen moduuliin ja liitä koodi nappiin...
Lisäsin varmistuksen, että kysyy solua riviltä minkä haluat päivittää, jotta ei tuu virheellistä päivitystä ja siinäkin vielä kelpoisuustarkistus ;-)

Keep EXCELing
@Kunde

koodi unohtui...

Sub Siirräenterillä()
Dim Solu As Range
On Error Resume Next
Set Solu = Application.InputBox("Valitse solu riviltä, jonka haluat päivittää", "Päivitys", , , , , , 8)
If Not Solu Is Nothing Then
Worksheets("Sheet2").Range("Rivi" & Solu.Row - 1).Resize(4).Copy Worksheets("Sheet2").Range("Rivi" & Solu.Row - 1).Offset(1)
Worksheets("Sheet1").Range("A" & Solu.Row & ":E" & Solu.Row).Copy Worksheets("Sheet2").Range("Rivi" & Solu.Row - 1).Resize(1)
End If
End Sub

Keep EXCELing
@Kunde

Taattua Kunde-laatua, kiitos, toimii aivan mahtavasti!
Niin kuin tapoihin ja tyyliin sopii, nälkä kasvaa syödessä.. tuli mieleen pari toivetta nykyiseen, jos onnistuu lisätä. Kokeilin puukottaa tuota koodia itse, mutta en saanut toimimaan.
1. Sheet1:n sarakkeet voisivat olla A-J. Tuo J-sarake toimisi tapahtumien pvm-sarakkeena kaavalla: J1-J200=NYT().
2. Sheet1:n rivejä voisi olla 2-200

Tattista vaan ;-)

Sub teeVarmuuskopio()
Dim Nimi As Name
Dim Rivi As Long
Dim Rivi2 As Long
Dim Rivi3 As Long
'muuta taulukon nimi sopivaksi
With Worksheets("Sheet2")
.Range("A:E") = ""
.Activate
For Each Nimi In ActiveWorkbook.Names
Nimi.Delete
Next
End With

Rivi = 2
Rivi2 = 6
Rivi3 = 1

For i = 1 To 200
'muuta taulukon nimi ja työkirjan nimetyn alueen nimi sopivaksi
Worksheets("Sheet2").Names.Add Name:="Rivi" & Rivi3, RefersToR1C1:="=Sheet2!R" & Rivi & "C1:R" & Rivi2 & "C5"
Rivi = Rivi 5
Rivi2 = Rivi2 5
Rivi3 = Rivi3 1
Next

Rivi = 2
Rivi2 = 6
For Each Solu In Worksheets("Sheet1").Range("A2:A100")
Solu.EntireRow.Copy Worksheets("Sheet2").Range("A" & Rivi)
Rivi = Rivi 5
Rivi2 = Rivi2 5
Next

End Sub
Sub Siirräenterillä()
Dim Solu As Range
On Error Resume Next
Set Solu = Application.InputBox("Valitse solu riviltä, jonka haluat päivittää", "Päivitys", , , , , , 8)
If Not Solu Is Nothing Then
Worksheets("Sheet1").Range("J" & Solu.Row) = Now()
Worksheets("Sheet2").Range("Rivi" & Solu.Row - 1).Resize(4).Copy Worksheets("Sheet2").Range("Rivi" & Solu.Row - 1).Offset(1)
Worksheets("Sheet1").Range("A" & Solu.Row & ":J" & Solu.Row).Copy Worksheets("Sheet2").Range("Rivi" & Solu.Row - 1).Resize(1)
End If
End Sub


Keep EXCELing
@Kunde

Tänx taas Kunde! Hyvin toimii korjattukin koodi, mutta yhden huomion tein silti vielä.
Kun täytän ensimmäisen kerran (Sheet1) riveille A2-I200 tietoa, kopioituu ne (Sheet2) 1/5 lokiriveille hienosti päivämäärää ja kelloaikaa myöten J-sarakkeeseen.
Mutta kun kirjoitan uuden tiedon (Sheet1) riveille, ensimmäiset tiedot putoavat yhden alaspäin (Sheet2) lokissa vajavaisina, ainoastaan sarakkeiden A-E osalle tulee edellisen tietoja, loput (F-J) leikkautuu pois. Näin tapahtuu muillakin lokiriveillä 2/5, 3/5, 4/5 ja 5/5.
Onnistuuko tuon viilailu vielä siten, että vanha tieto säilyisi lokissa kokonaisena, se kun olisi se oleellinen osa tuota ajatustani.
Toimivana tämä tulee olemaan erittäin käyttökelpoinen työkalu työarjessa. Juuri tuon lokin ansiosta tämä onkin niin mainio.
Aivan mahtavaa kyllä, että tällä palstalla löytyy asiantuntemusta tällaisiin ongelmiin.

Joo mun moka kun en muuttanut lähtötietoja testissä, niin en huomannut...

muuta tää rivi tommoseksi
'muuta taulukon nimi ja työkirjan nimetyn alueen nimi sopivaksi
Worksheets("Sheet2").Names.Add Name:="Rivi" & Rivi3, RefersToR1C1:="=Sheet2!R" & Rivi & "C1:R" & Rivi2 & "C10"

ja sit toimii ...

Keep EXCELing
@Kunde

Ihan mahtava juttu.. Kiitos taas!
Tuli vielä kysymys mieleen, pitäisikö Sheet1:llä olla mahdollista käyttää sarakkeissa (B2-H200 välillä)Tietojen kelpoisuuden tarkistus -alaspudotusvalikoita, joista voisi noutaa jollain toisella Sheetillä olevaa tietoa? Se helpottaisi lähinnä kirjoitustaakkaa jatkossa.
Jos ei ole mahdollista, niin se oli sitten tässä.
Kiitos vielä kovasti ja Hyvää pääsiäistä Kunde! Kuten muillekin jelppaajille.

Helppohan se on tehdä ja ei siihen koodia tartte. Mutta voidaan se koodiinkin lisätä jos kerrot kelpoisuusalueen.
Munarikasta pääsiäistä kaikille!

Keep EXCELing
@Kunde

Ok.. arvelinkin sen onnistuvan. Vielä en ole kokeillut, mutta uskon suoriutuvani tuosta urakasta. Kelpoisuusalue olisi kuitenkin Sheet1 B2-H200 ja lähde Sheet2 B2-H10. Hmm.. ai sen saisi koodiinkin upotettua. Kokeilen ensin perinteistä tyyliä.. jos en onnistu, käännyn puoleesi. :)
Tänx vastauksesta taas.

Vielä tuli yksi lisätoive mieleen ko. työkirjaan.
Vaikkakin kyseinen työkirja on usean henkilön käytössä työpaikan palvelimella (X:\) -haluaisin muutosten vielä kopioituvan omalla koneellani olevalle identtiselle kopiolle.
Minkälainen koodi tulisi omaan tai palvelimella olevaan työkirjaan, jotta tiedot päivittyisivät?

X.llä olevaan tiedoston ThisWorkbook moduuliin...

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'muuta polku ja nimi sopivaksi
ActiveWorkbook.SaveAs Filename:="C:\temp\koe.xlsm"
End Sub


Keep EXCELing
@Kunde

ThisWorkBook moduuliin...

Sub Auto_Open()
Varmuuskopio
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime Now(), "Varmuuskopio", , False
End Sub

tavalliseen moduuliin...

Option Explicit
Sub Varmuuskopio()
'muuta taulukon nimi ja alue sopivaksi
ThisWorkbook.Worksheets("Sheet1").Range("A:I").ClearContents
'muuta kopioitavan datan polku, lähdetaulukko ja lähdealue sekä kopioitava alue sopivaksi
GetData "X\test.xlsx", "Taul1", "A1:I200", Sheets("Taul1").Range("A1")
'muuta makron uudelleenajon aika sopivaksi - nyt 1 min
Application.OnTime Now TimeValue("00:01:00"), "Varmuuskopio"
End Sub


Public Sub GetData(Lähde As Variant, Lähdetaulukko As String, Lähdealue As String, Originaali As Range)
Dim Conn As Object
Dim Tiedot As Object
Dim Connect As String
Dim SQL As String

'tsekataan versio
If Val(Application.Version) < 12 Then
Connect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Lähde & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Lähde & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If

SQL = "SELECT * FROM [" & Lähdetaulukko$ & "$" & Lähdealue$ & "];"


Set Conn = CreateObject("ADODB.Connection")
Set Tiedot = CreateObject("ADODB.Recordset")

Conn.Open Connect
Tiedot.Open SQL, Conn, 0, 1, 1

Originaali.Cells(1, 1).CopyFromRecordset Tiedot

Tiedot.Close
Set Tiedot = Nothing
Conn.Close
Set Conn = Nothing

End Sub

nyt ei väliä onko serverillä oleva tiedosto auki vaiko kiinni...
lukee siis vaan Taul1 tiedot omalle koneelle tietyin väliajoin, oliko tarkoitus näin?

Keep EXCELing
@Kunde

Suorita makro VArmuuskopio rivi riviltä. Tuleeko virheilmoitusta ?

Kunde

Huomasin juuri, että olet kopioinut koodin Taul1 moduuliin, etkä tavalliseen moduuliin(INSERT/MODULE)...
siinäpä se syy lienee.

Keep EXCELing
@Kunde

no nyt koodisi sitten oikeassa paikassa...
klikkaa moduulissa(oletuksena Module1, ellet ole nimennyt uudelleen tai lisännyt aiemmin moduulia) hiirellä jossain kohtaa Varmuuskopio makron jotain riviä rivien Sub Varmuuskopio() ja End Sub välillä.
kursosin pitäisi nyt vilkkua ko. makron jollain koodirivillä
Paina F8 ja Sub Varmuuskopio() rivi menee keltaiseksi
F8 ja ThisWorkbook.Worksheets("Sheet1").Range("A:J").ClearContents aktivoituu
F8 jne.
ohjelma suoritetaan siis rivi riviltä

muuta toi Varmuuskopio tälläiseksi niin tiedetään tuleeko virhe

Sub Varmuuskopio()
On Error GoTo virhe
'muuta taulukon nimi ja alue sopivaksi
ThisWorkbook.Worksheets("Sheet1").Range("A:J").ClearContents
'muuta kopioitavan datan polku, lähdetaulukko ja lähdealue sekä kopioitava alue sopivaksi
GetData ThisWorkbook.Path & "\test.xls", "Sheet1", "A1:J1000", Sheets("Sheet1").Range("A1")
'muuta makron uudelleenajon aika sopivaksi - nyt 1 min
Application.OnTime Now TimeValue("00:01:00"), "Varmuuskopio"
Exit Sub
virhe:
MsgBox "Tänne ei pitänyt tulla!"
End Sub

tuleeko mitään virhettä ja millä rivillä se siirtyi tonne mistä tahansa koodin aikana eli se rivi mikä oli viimeksi keltainen aiheuttaa sitten virheen...

ollaan sit viisampia taas

Keep EXCELing
@Kunde

Kiitos vastauksesta Kunde. Yritän ratkaista dilemmaani mahd. pian. Vaivaan taas kyllä sinua, jos ei rupea vorkkimaan. :)

Kundepuu kirjoitti:

no nyt koodisi sitten oikeassa paikassa...
klikkaa moduulissa(oletuksena Module1, ellet ole nimennyt uudelleen tai lisännyt aiemmin moduulia) hiirellä jossain kohtaa Varmuuskopio makron jotain riviä rivien Sub Varmuuskopio() ja End Sub välillä.
kursosin pitäisi nyt vilkkua ko. makron jollain koodirivillä
Paina F8 ja Sub Varmuuskopio() rivi menee keltaiseksi
F8 ja ThisWorkbook.Worksheets("Sheet1").Range("A:J").ClearContents aktivoituu
F8 jne.
ohjelma suoritetaan siis rivi riviltä

muuta toi Varmuuskopio tälläiseksi niin tiedetään tuleeko virhe

Sub Varmuuskopio()
On Error GoTo virhe
'muuta taulukon nimi ja alue sopivaksi
ThisWorkbook.Worksheets("Sheet1").Range("A:J").ClearContents
'muuta kopioitavan datan polku, lähdetaulukko ja lähdealue sekä kopioitava alue sopivaksi
GetData ThisWorkbook.Path & "\test.xls", "Sheet1", "A1:J1000", Sheets("Sheet1").Range("A1")
'muuta makron uudelleenajon aika sopivaksi - nyt 1 min
Application.OnTime Now TimeValue("00:01:00"), "Varmuuskopio"
Exit Sub
virhe:
MsgBox "Tänne ei pitänyt tulla!"
End Sub

tuleeko mitään virhettä ja millä rivillä se siirtyi tonne mistä tahansa koodin aikana eli se rivi mikä oli viimeksi keltainen aiheuttaa sitten virheen...

ollaan sit viisampia taas

Keep EXCELing
@Kunde

Lue lisää

Dodiin.. yritin tehdä ohjeesi mukaan. Alla miten koodi on nyt mulla ja.. tuli myös herja (lopussa)

Option Explicit
---------------------------------------------------------------------------------------------------------------------
Sub Varmuuskopio()
On Error GoTo virhe
ThisWorkbook.Worksheets("Taul1").Range("A:I").ClearContents
GetData ThisWorkbook.Path & "X:\Polku\Polku\Polku\Tiedosto.xlsx", "Taul1", "A1:I200", Sheets("Taul1").Range("A1")
Application.OnTime Now TimeValue("00:01:00"), "Varmuuskopio"
Exit Sub
virhe:
MsgBox "Tänne ei pitänyt tulla!"
End Sub
--------------------------------------------------------------------------------------------------------------------
(tämä tuli keltaisella:)
Public Sub GetData(Lähde As Variant, Lähdetaulukko As String, Lähdealue As String, Originaali As Range)
.....
...
...
....
....
(tämä tuli siniseksi -kuin hiirellä maalaten)
Connect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _

Korjaus:
Rivi: GetData ThisWorkbook.Path... oli viimeisin toimiva rivi..
Riviltä: Application.OnTime Now ... hyppäsi alla olevaan:

(tämä tuli keltaisella:)
Public Sub GetData(Lähde As Variant, Lähdetaulukko As String, Lähdealue As String, Originaali As Range)
.....
...
...
....
....
(tämä tuli siniseksi -kuin hiirellä maalaten)
Connect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _

muuta
GetData ThisWorkbook.Path & "X:\Polku\Polku\Polku\Tiedosto.xlsx", "Taul1", "A1:I200", Sheets("Taul1").Range("A1")

GetData "X:\Polku\Polku\Polku\Tiedosto.xlsx", "Taul1", "A1:I200", Sheets("Taul1").Range("A1")

Keep EXCELing
@Kunde

Kundepuu kirjoitti:

muuta
GetData ThisWorkbook.Path & "X:\Polku\Polku\Polku\Tiedosto.xlsx", "Taul1", "A1:I200", Sheets("Taul1").Range("A1")

GetData "X:\Polku\Polku\Polku\Tiedosto.xlsx", "Taul1", "A1:I200", Sheets("Taul1").Range("A1")

Keep EXCELing
@Kunde

Lue lisää

Harmillista.. joku tökkii nyt pahasti, kun tulee sama virhe, eli en saa toimimaan. Edelleen menee keltaiseksi:
Rivi: Public Sub GetData(Lähde As Variant, Lähdetaulukko As String, Lähdealue As String, Originaali As Range) ja
Rivi: Connect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ -maalautuu siniseksi.

Mikä veriso Excelistä sulla on?

kirjoita rivit uusiki ilman _ merkkiä samalle riville

Connect = "Provider=Microsoft.Jet.OLEDB.4.0;" &"Data Source=" & Lähde & ";" & "Extended Properties=""Excel 8.0;HDR=No"";"

ja

Connect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Lähde & ";" &
"Extended Properties=""Excel 12.0;HDR=No"";"

ne pitäisi jäädä mustaksi fiksauksen jälkeen

Hienoa, nyt sain toimimaan! Kiitos kovasti Kunde avustasi.
Mulla on 2013 versio Excelistä duunissa, missä siis käytän tätä. Kotona 2007 versio.
Olisiko muuten tuohon koodiin ollut mahdollista sisällyttää solujen Lisäkommenttien (se punainen kolmio solussa) kopiointiominaisuus "Varmuuskopiolle"?

valitettavasti ei tohon koodiin pysty lisäämään kommentteja, mutta tolla koodilla se onnaa....


Option Explicit
Sub Varmuuskopio()
'muuta taulukon nimi ja alue sopivaksi
ThisWorkbook.Worksheets("TAul1").Range("A:I").ClearContents
Kopioi
'muuta makron uudelleenajon aika sopivaksi - nyt 1 min
Application.OnTime Now TimeValue("00:01:00"), "Varmuuskopio"
End Sub

Sub Kopioi()
Dim wbKohde As Workbook
Dim wbTämä As Workbook
On Error Resume Next
Application.CutCopyMode = False
Set wbTämä = ThisWorkbook
wbTämä.Worksheets("Taul1").Range("A1:I200").Clear

If Not OnkoAuki("X:\Polku\Polku\Polku\Tiedosto.xlsx") Then
Set wbKohde = Workbooks.Open("X:\Polku\Polku\Polku\Tiedosto.xlsx")
wbKohde.Worksheets("Taul1").Range("A1:I200").Copy
wbTämä.Worksheets("Taul1").Range("A1").PasteSpecial
wbKohde.Close

Else
Set wbKohde = Workbooks("Tiedosto.xlsx")
wbKohde.Worksheets("Taul1").Range("A1:I200").Copy
wbTämä.Worksheets("Taul1").Range("A1").PasteSpecial

End If

wbTämä.Activate
Set wbKohde = Nothing
Set wbTämä = Nothing
Application.CutCopyMode = False
Application.DisplayAlerts = True
End Sub

Public Function OnkoAuki(Tiedostonnimi As String) As Boolean
On Error Resume Next
Open Tiedostonnimi For Binary Access Read Lock Read As #1
Close #1
OnkoAuki = IIf(Err.Number > 0, True, False)
On Error GoTo 0
End Function

Keep EXCELing
@Kunde

Kundepuu kirjoitti:

valitettavasti ei tohon koodiin pysty lisäämään kommentteja, mutta tolla koodilla se onnaa....


Option Explicit
Sub Varmuuskopio()
'muuta taulukon nimi ja alue sopivaksi
ThisWorkbook.Worksheets("TAul1").Range("A:I").ClearContents
Kopioi
'muuta makron uudelleenajon aika sopivaksi - nyt 1 min
Application.OnTime Now TimeValue("00:01:00"), "Varmuuskopio"
End Sub

Sub Kopioi()
Dim wbKohde As Workbook
Dim wbTämä As Workbook
On Error Resume Next
Application.CutCopyMode = False
Set wbTämä = ThisWorkbook
wbTämä.Worksheets("Taul1").Range("A1:I200").Clear

If Not OnkoAuki("X:\Polku\Polku\Polku\Tiedosto.xlsx") Then
Set wbKohde = Workbooks.Open("X:\Polku\Polku\Polku\Tiedosto.xlsx")
wbKohde.Worksheets("Taul1").Range("A1:I200").Copy
wbTämä.Worksheets("Taul1").Range("A1").PasteSpecial
wbKohde.Close

Else
Set wbKohde = Workbooks("Tiedosto.xlsx")
wbKohde.Worksheets("Taul1").Range("A1:I200").Copy
wbTämä.Worksheets("Taul1").Range("A1").PasteSpecial

End If

wbTämä.Activate
Set wbKohde = Nothing
Set wbTämä = Nothing
Application.CutCopyMode = False
Application.DisplayAlerts = True
End Sub

Public Function OnkoAuki(Tiedostonnimi As String) As Boolean
On Error Resume Next
Open Tiedostonnimi For Binary Access Read Lock Read As #1
Close #1
OnkoAuki = IIf(Err.Number > 0, True, False)
On Error GoTo 0
End Function

Keep EXCELing
@Kunde

Lue lisää

Kiitos Kunde jälleen avusta.
"Excel-projektini" keskeytyy hetkeksi työreissun takia. Palaan aiheeseen ja tuohon viimeiseen koodiisi myöhemmin.
Sen verran kysyn kuitenkin, että estääkö jokin taulukon tai työkirjan lukitseminen/suojaaminen joidenkin makrojen toimimisen.. noin yleensä? Tähänkin palaan myöhemmin vielä tarvittaessa.

riippuu mitä makro tekee suojaus voi aiheuttaa virheen makron suorituksen tai sit ei ...
mutta koodillahan siitäkin selviää kivuttomasti ;-)

Keep EXCELing
@Kunde

ThisWorkBook moduuliin...

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim vastaus

vastaus = MsgBox("Keep EXCELing" & vbNewLine & "@Kunde" & "Jos haluat tehdä vielä muutoksia, vastaa EI", vbInformation vbYesNo, "Muistilista")
'ei nappi= 7 kyllä=6 ja silloin perutaan sulkeminen

If vastaus = 7 Then Cancel = True
End Sub

Keep EXCELing
@Kunde

Kiitos jälleen Kunde!
Tuo oli juuri nappiin se mitä halusin. Luit näemmä hieman rivienkin välistä, mitä toivoin. :)
Duunit häiritsee ja sotkee päänuppia sen verran, että jotain piti vielä kysyä tähän omaan osiooni liittyen. Jos hieman tuonnempana vielä jaksat innostua aiheestani ja jeesimään -käännyt rohkeasti puoleesi.
Nyt nautin tämän hetkisestä tuotosta ja avustasi. Tuo viimeisin juttu oli mainio apulainen tällaiselle lahopäälle. ;D

Kiitos siis vielä!

Kundepuu, vaivaisin sua taas tällä koodillasi, jonka tarkoitus oli siis noutaa päivitettävä tieto toisesta Excel-työkirjasta, vaikka se olisi suljettu.
Pitäisikö tuon koodin ja aika-asetuksen toimia oli lähde kiinni tai auki?
Nyt koodi toimii siten, että se täytyy itse päivittää, jos lähteessä on tapahtunut jotain muutoksia.
Kiitos kovasti, jos tähän saisi korjausliikkeen. :)
Alla hieman modattu koodisi:

Option Explicit
Sub Varmuuskopio()
ThisWorkbook.Worksheets("Taul1").Range("A:J").ClearContents
GetData "X:\polku\polku\polku\tiedosto.xlsm", "Taul1", "A2:J200", Sheets("Taul1").Range("A2")
Application.OnTime Now TimeValue("00:01:00"), "Varmuuskopio"
End Sub
Public Sub GetData(Lähde As Variant, Lähdetaulukko As String, Lähdealue As String, Originaali As Range)
Dim Conn As Object
Dim Tiedot As Object
Dim Connect As String
Dim SQL As String
If Val(Application.Version) < 12 Then
Connect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Lähde & ";" & "Extended Properties=""Excel 8.0;HDR=No"";"
Else
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Lähde & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
End If
SQL = "SELECT * FROM [" & Lähdetaulukko$ & "$" & Lähdealue$ & "];"
Set Conn = CreateObject("ADODB.Connection")
Set Tiedot = CreateObject("ADODB.Recordset")
Conn.Open Connect
Tiedot.Open SQL, Conn, 0, 1, 1
Originaali.Cells(1, 1).CopyFromRecordset Tiedot
Tiedot.Close
Set Tiedot = Nothing
Conn.Close
Set Conn = Nothing
End Sub

toimii riippumatta siitä onko lähdetiedosto auki tai kiinni ja nyt mallisi mukaan 1 min välein suorittaa haun

Koodisi kyllä toimii.. mutta omalla kohdallani niin, että "nuuskiminen" ei käynnisty ilman ekaa tönäisyä, eli omaa päivitystä. Jos jätän "tönäisyn" jäljiltä kohdetiedoston auki ja tieto muuttuu lähteessä -homma toimii.

Paria paranteluvaihtoehtoa olisin kuitenkin vielä kysynyt, jos ne on mahdollisia toteuttaa.
1. Vaihtoehto. Onko mahdollista, että (ajastetun nuuskimisen) tieto päivittyisi kohteeseen _vain_ jos lähteessä on tieto muuttunut jollain solulla ("Taul1", "A2:J200").
2. Vaihtoehto. Jos jättäisikin tuon ajastuksen pois ja kävisi manuaalisesti (nappia painamalla) noutamassa _vain_ muuttuneet tiedot. Mitenköhän tuollainen muutos olisi mahdollista tuohon juuri laittamaani koodiisi.
Eli ajastettu tai manuaalinen _vain_ muuttuneen tiedon haku ja päivitys lähteestä.

poista vanhat makrot...

1. vaihtoehto

lähdetiedoston Taul1 moduuliin ja tallenna

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Kohde As Workbook
If Not Intersect(Target, Range("A2:J200")) Is Nothing Then
If Not OnkoAuki("C:\temp\Hakukone.xlsm") Then
' muuta kohdetyökirjan nimi sopivaksi.
Set Kohde = Workbooks.Open("C:\temp\Hakukone.xlsm")
Target.Copy Kohde.Worksheets("Taul1").Range(Target.Address)
Kohde.Save
Kohde.Close
Else
' muuta kohdetyökirjan nimi sopivaksi.
Set Kohde = Workbooks("Hakukone.xlsm")
Target.Copy Kohde.Worksheets("Taul1").Range(Target.Address)
End If
End If
End Sub

2. vaihtoehto nappiin koodi

Sub Varmuuskopio()
Dim Conn As Object
Dim Tiedot As Object
Dim Connect As String
Dim SQL As String
ThisWorkbook.Worksheets("Taul1").Range("A:J").ClearContents
If Val(Application.Version) < 12 Then
Connect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & "X:\polku\polku\polku\tiedosto.xlsm" & ";" & "Extended Properties=""Excel 8.0;HDR=No"";"
Else
'Connect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & "X:\polku\polku\polku\tiedosto.xlsm" & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
End If
SQL = "SELECT * FROM [" & "Taul1" & "$" & "A2:J200" & "];"
Set Conn = CreateObject("ADODB.Connection")
Set Tiedot = CreateObject("ADODB.Recordset")
Conn.Open Connect
Tiedot.Open SQL, Conn, 0, 1, 1
Sheets("Taul1").Range("A2").Cells(1, 1).CopyFromRecordset Tiedot
Tiedot.Close
Set Tiedot = Nothing
Conn.Close
Set Conn = Nothing
End Sub


Keep EXCELing ;-)
@Kunde

unohtui liittää Onkoauki makro ja se tavalliseen moduuliin...

Public Function OnkoAuki(Tiedostonnimi As String) As Boolean

On Error Resume Next

Open Tiedostonnimi For Binary Access Read Lock Read As #1

Close #1

OnkoAuki = IIf(Err.Number > 0, True, False)

On Error GoTo 0

End Function

Keep EXCELing

@Kunde

Sain kun sainkin tuon toimimaan, kun viimein tajusin ottaa tuosta jälkimmäisestä 'Connect:sta tuon ylähipsun (`) pois.
Tilanne duunissa muuttunut siten, että lähdetiedostoa ei pidetäkään enää servulla vaan ns. yhteiskoneella, jolloin tämän päivittyneiden tietojen seuraamistarve valui hieman hukkaan.
Koodi on tallessa ja otetaan tarvittaessa käyttöön.

Kiitos Kunde taas jälleen panoksestasi!

poista SiirräEnterillä makro ja liitä alaoleva TAUL1 moduuliin...

toimii nyt automaattisesti aina kun solu alueella muuttaa arvoa, eikä puoliautomaattisesti... ;-)

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
Range("J" & Target.Row) = Now()
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
End If
Application.EnableEvents = True
End Sub


Keep EXCEling
@Kunde

Kundepuu kirjoitti:

poista SiirräEnterillä makro ja liitä alaoleva TAUL1 moduuliin...

toimii nyt automaattisesti aina kun solu alueella muuttaa arvoa, eikä puoliautomaattisesti... ;-)

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
Range("J" & Target.Row) = Now()
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
End If
Application.EnableEvents = True
End Sub


Keep EXCEling
@Kunde

Lue lisää

Toimii hienosti noinkin.. kiitos kovasti. Mun tapauksessa olisi kätevämpää, että saisi ensin tehdä muutokset haluttuihin soluihin samalla rivillä ja sitten vasta painaisi "Päivitä" -nappia. Nyt jokainen solutiedon muuttaminen (samalla rivillä) aiheuttaa lokiin turhia historiarivejä.
Eli onko hankalaa koodata tuollaista toivetta.

nyt esim. koodissa kun kirjoitat jotakin L-sarakkeessa suorittaa koodin ja päivittää ko. rivin tiedot ja tyhjentää aktiivisen solun.Ehkä fiksumpi kuin liittää nappiin? Jos ei OK , niin tehdään sitten nappiin koodi

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

Application.EnableEvents = False

If Not Intersect(Target, Range("L2:L200")) Is Nothing Then

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

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

Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
Target = ""
End If


Application.EnableEvents = True

End Sub
Keep EXCELing
@Kunde

edelleen pitäytyisin tässä L sarakkeessa koodissa (tai joku muu sarake)...
nyt kun arvoja muuttaa niin kirjoittaa "PÄIVITÄ" sarakeeseen L- sarakkeeseen ja helppo nähdä mitä tarttee päivittää. Sitten vaan siirryt "PÄIVITÄ" teksti soluun ja DELETE tai kirjoittaa mitä vaan niin päivitys tapahtuu.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Päivitä As Boolean
On Error Resume Next

Application.EnableEvents = False
Päivitä = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
Range("J" & Target.Row) = Now()
Range("L" & Target.Row) = "PÄIVITÄ"
Päivitä = True
End If
If Not Intersect(Target, Range("L2:L200")) Is Nothing Then
If Päivitä = False Then
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
Target = ""
End If
End If
Application.EnableEvents = True
End Sub

KEEP SIMAing
@Kunde

Mainiota Kunde! Vaikkakin se "Päivitä" -nappula olisi ollut mieleen, niin tuo sinun ehdottamasi "PÄIVITÄ" -teksti on kyllä varsin mainio.. varsinkin kun laitoin ne värjäytymään punaisella värillä ja hiirellä tuplaklikkaamalla tuota "PÄIVITÄ" -tekstiä ( toisessa solussa kerran) -sen saa pois kirjoittamatta mitään L-sarakkeeseen. Toimii siis!

Suuret kiitokset taas Kunde!

Lisätoiveita tulee näköjään lisää ja lisää.. Miten saisin siirrettyä Taul3:ssa kaikki sarakkeet yhden oikealle siten, että A-sarakkeeseessa voisin ilmaista mitä riviä esim. A2-A6 edustavat Taul1:ssä?
Ajatuksenani olisi, että yhdistäisin Taul3:ssa solut esim. A2-A6, A7-A1, A12-A16.. jne ja kirjoittaisin siihen: "Taul1 Rivi 2", "Taul1 Rivi 3", "Taul1 Rivi 4"... jne. Olisi siten helppo hahmottaa Taul3:ssa mitä riviä tuo 5 rivin historialoki edustaa Taul1:ssä.

Mahtoiko aueta idea? :)

päivitetty makro

Sub teeVarmuuskopio()
Dim Nimi As Name
Dim Rivi As Long
Dim Rivi2 As Long
Dim Rivi3 As Long
With Worksheets("Taul3")
.Range("A:K") = ""
.Activate
For Each Nimi In ActiveWorkbook.Names
Nimi.Delete
Next
End With
Rivi = 2
Rivi2 = 6
Rivi3 = 1
For i = 1 To 200
Worksheets("Taul3").Names.Add Name:="Rivi" & Rivi3, RefersToR1C1:="=Taul3!R" & Rivi & "C2:R" & Rivi2 & "C11"
Worksheets("Taul3").Range("A" & Rivi & ":A" & Rivi2).Select
With Selection
.Merge
.MergeCells = True
.FormulaR1C1 = "Rivi" & Rivi3
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Rivi = Rivi 5
Rivi2 = Rivi2 5
Rivi3 = Rivi3 1
Next
Rivi = 2
Rivi2 = 6
For Each Solu In Worksheets("Taul1").Range("A2:A200")
Solu.Resize(1, 10).Copy Worksheets("Taul3").Range("B" & Rivi)
Rivi = Rivi 5
Rivi2 = Rivi2 5
Next
Rivi = 2
Rivi2 = 6
For i = 1 To 200
Worksheets("Taul3").Range("A2:A6").Select
Rivi = Rivi 5
Rivi2 = Rivi2 5
Rivi3 = Rivi3 1
Next
End Sub


Keep EXCELing
@Kunde

Lähdin villisti kokeilemaan ilman laittamaasi koodia.. ja siirsin kaikki nykyiset Taul3:n sarakkeet yhden oikealle, eli lisäsin siis käytännössä äärivasemmalle yhden uuden sarakkeen. "Uuden" A-sarakkeen. Yhdistin postaukseni mukaisesti (A2-A6, A7-A11...) soluja ja yllätyin positiivisesti, kun kaikki toimii edelleen.
Syytä en tiedä toimimiseen.. osaatko sinä sanoa. Pääasia, että toimii. :)

Jätän toistaiseksi hyödyntämättä koodisi ja palaan siihen, jos omassa kokeilussani ilmenee kummallisuuksia.
Btw.. Miten koodisi toteuttaa tuon toiveeni ja tuoko se tullessaan jotain oleellista, eli jotain minkä puuttumisen huomaan em. omassa kokeilussani. :)

Joo kyllähän sen noin pitääkin toimia. En tiedä mitä mokasin, silloin kun koodia väsäsin ja ajattelin, että pelkällä sarakkeen siirrollahan se pitäisi toimia, mutta ei vaan silloin toiminut... :-(
Muutettu koodi nimeää alueet alkaen B -sarakkeesta ja A sarakkeeseen lisää tekstit ja yhdistaa solut A2-A6, A7-A11 jne...

Keep EXCELing
@Kunde

Kundepuu kirjoitti:

edelleen pitäytyisin tässä L sarakkeessa koodissa (tai joku muu sarake)...
nyt kun arvoja muuttaa niin kirjoittaa "PÄIVITÄ" sarakeeseen L- sarakkeeseen ja helppo nähdä mitä tarttee päivittää. Sitten vaan siirryt "PÄIVITÄ" teksti soluun ja DELETE tai kirjoittaa mitä vaan niin päivitys tapahtuu.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Päivitä As Boolean
On Error Resume Next

Application.EnableEvents = False
Päivitä = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
Range("J" & Target.Row) = Now()
Range("L" & Target.Row) = "PÄIVITÄ"
Päivitä = True
End If
If Not Intersect(Target, Range("L2:L200")) Is Nothing Then
If Päivitä = False Then
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
Target = ""
End If
End If
Application.EnableEvents = True
End Sub

KEEP SIMAing
@Kunde

Lue lisää

No joo.. tulihan mulla taas Kundelle lisätoive tuohon "Päivitä" -koodiin. :))
Nyt kun muuttaa tietoa jonkun rivin soluissa (sarakkeet A-I) -tulee J-sarakkeeseen muutospäivämäärä ja L-sarakkeeseen "Päivitä" teksti. Tämä ok ja saa toimia jatkossakin pääosin näin.
Saisiko koodiin kuitenkin sellaisen poikkeuksen, että se kuitenkin sallisi tehdä I-sarakkeeseen muutoksia ja J-sarakkeeseen tulisi muutospäivämäärä -ilman
"Päivitä" -kehotetta L-sarakkeeseen?
Eli koodi toimisi kuten ennenkin, mutta sallisi I-sarakkeen muutokset ja J-sarakkeeseen tulisi kuitenkin muutospvm ilman Päivitä-kehotetta.

Tällä pienellä muutoksella saisi Taul1:lle infoa ilman Päivitys-ilmoitusta.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Päivitä As Boolean
On Error Resume Next

Application.EnableEvents = False
Päivitä = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
If Not Intersect(Target, Range("I2:I200")) Is Nothing Then
Range("J" & Target.Row) = Now()
Päivitä = True
Else
Range("J" & Target.Row) = Now()
Range("L" & Target.Row) = "PÄIVITÄ"
Päivitä = True
End If
End If
If Not Intersect(Target, Range("L2:L200")) Is Nothing Then
If Päivitä = False Then
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
Target = ""
End If
End If
Application.EnableEvents = True
End Sub

Keep EXCELing
@Kunde

Juma.. toihan toimii kuin junan vessa. :) Kiitos tuosta Kunde.
Tuo "Päivitys"-kuvio hakee selvästikin muotoaan ja se ei selviä kuin kokeilemalla.
Olisiko ollut mahdollista saada sellainen versio tuosta mainiosta koodistasi, että "Päivitä"-kehote L-sarakkeeseen tulisi _vasta_ kun I-sarakkeen soluun kirjoittaisi jotain ja se tyhjenisi L-sarakkeen "Päivitä"-tekstiä tuplaklikkaamalla, kuten L-sarakekin tyhjenee.
Voi tuntua turhauttavalta tämän muodon etsiminen.. mutta vakuutan, että se tulee hyvään ja kovaan käyttöön. :))

Tarkennus:
Sarakkeisiin A-H voisi kirjoittaa vapaasti tietoa, mutta vasta kun I-sarakkeeseen tulee infoa ilmestyy J-sarakkeeseen muutospäivämäärä ja L-sarakkeeseen "Päivitä" -teksti. Päivittämisen jälkeen I, J ja L-sarakkeet tyhjenisivät.
Onko hankala? :))

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
If Not Intersect(Target, Range("I2:I200")) Is Nothing Then
Range("J" & Target.Row) = Now()
Päivitä = True
Range("L" & Target.Row) = "PÄIVITÄ"
End If
End If
If Not Intersect(Target, Range("L2:L200")) Is Nothing Then
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
Target = ""
Range("I" & Target.Row) = ""
End If

Application.EnableEvents = True
End Sub


Keep EXCELing
@Kunde

olikin tullut uusi korjaus jo postausten välillä...
nyt sitten J sarakkeen solukin tyhjenee

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
If Not Intersect(Target, Range("I2:I200")) Is Nothing Then
Range("J" & Target.Row) = Now()
Päivitä = True
Range("L" & Target.Row) = "PÄIVITÄ"
End If
End If
If Not Intersect(Target, Range("L2:L200")) Is Nothing Then
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
Target = ""
Range("I" & Target.Row) = ""
Range("J" & Target.Row) = ""
End If

Application.EnableEvents = True
End Sub

Keep EXCELing

@Kunde

Tämä on aivan huikea..! Alkaa tuntua siltä, että tällä versiolla mennään pitkään.
Olin tosiaan ennättänyt miettiä tuossa välissä tarkemmin tuota ekaa toivetta, kunnes tämä viimeisin putkahti päähäni.. että NÄINHÄN sen pitääkin olla.
Kerrassaan hienoa Kunde. Kiitän jälleen kerran vaivannäöstäsi!

Menee ehkä jo pilkun viilailuiksi, mutta olisiko ollut mahdollista lisätä vielä tuohon
"Päivitä"-sanan painamisen yhteyteen pieni lisäsuoritus. Eli nyt kun Päivitä-sanaa tuplaklikataan tyhjenee I, J ja L-sarakkeet ao. rivien osalta. Lisätoiveena olisi saada A-sarakkeen (ao. soluun) tekstin yliviivaus. Tämä toimisi vain yhtenä infona käyttäjälle ja olisi poistettavissa solusta vaikka Ctrl 5 näppäinyhdistelmällä.
Jos mahdollista, niin tämä alkaisi olla perfect! :))

melkein mikä vaan on mahdollista Excelissä...

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
If Not Intersect(Target, Range("I2:I200")) Is Nothing Then
Range("J" & Target.Row) = Now()
Päivitä = True
Range("L" & Target.Row) = "PÄIVITÄ"
End If
End If
If Not Intersect(Target, Range("L2:L200")) Is Nothing Then
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":J" & Target.Row).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(1)
Target = ""
Range("I" & Target.Row) = ""
Range("J" & Target.Row) = ""
Range("A" & Target.Row).Font.Strikethrough = True
End If

Application.EnableEvents = True
End Sub

Keep EXCELing
@Kunde

Kyllä Exceli näköjään taipuu moneen.. Tämä viimeisen lisäys oli tosi tervetullut. Tuo yliviivattu solun teksti jää kätevästi odottamaan jatkotoimenpiteitä.
Kiitos tästäkin taas Kunde ja hyviä pyhiä! :)

Vieläkö puukottaisit hieman tuota koodiasi..
Koodi saa tehdä edelleen kaikki nuo nykyiset temput, mutta muutama lisätoive olisi.
En tiedä mikä olisi kronologisesti oikea järjestys ilmaista toiveeni, mutta lähtötilanne on jo nyt toimiva koodi.
(Alla hieman itse puukottama ja toimiva koodisi.)

1. Lisätoive:
"Päivitä"-tekstin tuplaklikkaamisen jälkeen myös A-sarakkeen solu tyhjenisi.
(Sen tekstin yliviivaus-ominaisuuden voi poistaa.)

2. Lisätoive:
Kun A-sarakkeen tyhjään soluun taas kirjoittaa jotain, ilmestyisi G-sarakkeen soluun päivämäärä ja aika =Nyt(). Tämä tilanne tallennetaan (Save) odottamaan jatkokäsittelyä.

Kun tyhjään I-sarakkeeseen kirjoitetaan jotain, ilmestyy H-sarakkeeseen päivämäärä ja aika =Nyt(), sekä J-sarakkeeseen "Päivitä"-teksti.

3.Lisätoive:
Kun nyt "Päivitä"-tekstiä tuplaklikkaa, tyhjenisi A, G, H, I ja J -sarakkeet. Nämä kaikki myös tallentuisivat sinne Taul3 historialokiin.

Saitko kiinni..? :)

Tässä toimiva viimeisin (itse puukottama) koodisi:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Not Intersect(Target, Range("A2:I200")) Is Nothing Then
If Not Intersect(Target, Range("I2:I200")) Is Nothing Then
Range("H" & Target.Row) = Now()
Päivitä = True
Range("J" & Target.Row) = "PÄIVITÄ"
End If
End If
If Not Intersect(Target, Range("J2:J200")) Is Nothing Then
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":H" & 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).Font.Strikethrough = True
End If
Application.EnableEvents = True
End Sub

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
Range("G" & Target.Row) = Now()
ThisWorkbook.Save
End If

If Not Intersect(Target, Range("B2:I200")) Is Nothing Then
If Not Intersect(Target, Range("I2:I200")) Is Nothing Then
Range("H" & Target.Row) = Now()
Range("J" & Target.Row) = "PÄIVITÄ"
End If
End If

If Not Intersect(Target, Range("J2:J200")) Is Nothing Then
Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Target.Row - 1).Offset(1)
Range("A" & Target.Row & ":H" & 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) = ""
End If

Application.EnableEvents = True
End Sub

Keep EXCELing
@Kunde

Todella hienoa työtä jälleen. Kiitos kovasti Kunde!
Jospa tällä pärjäisin pitkään.. Jää nähtäväksi. ;D
Viikonloppuja!

Hyvin pärjäsin vkl:n tällä.. mutta heti tuli parannustoive koodiin.
Eli nyt kun J-sarakkeeseen tulevaa Päivitä-sanaa tuplaklikkaa, tyhjenee osa rivin soluista. Saman asian tekee, vaikka tuplaklikkaa tyhjää J-sarakkeen solua.
Parannustoive: Pystyykö koodilla estämään tyhjän J-sarakkeen solun tuplaklikkauksen tyhjentämistoiminteen? Toisin sanoen jos J-sarake on tyhjä ei tuplaklikkaus ns. "toimisi". Tällä estettäisiin turhien ja vahinkoklikkausten toimet.

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
Range("G" & Target.Row) = Now()
ThisWorkbook.Save
End If

If Not Intersect(Target, Range("B2:I200")) Is Nothing Then
If Not Intersect(Target, Range("I2:I200")) Is Nothing Then
Range("H" & Target.Row) = Now()
Range("J" & Target.Row) = "PÄIVITÄ"
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 & ":H" & 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) = ""
End If
End If

Application.EnableEvents = True
End Sub

Keep EXCELing
@Kunde

Ihan mahtavaa Kunde, Kiitos jälleen!
Olen aivan tohkeissani tämän taulukkoni kanssa ja toiveiden kaivo on näköjään ehtymätön.. vaivaan siis taas.. :))
Tyhjään I-sarakkeeseen kun kirjoittaa jotain (esim. nimen) -tuo se H-sarakkeeseen päivämäärän ja ajan, sekä J-sarakkeeseen Päivitä-tekstin.
Tämä on OK.
Mutta.. jos tuplaklikkaan tyhjää I-saraketta, saa se aikaan saman kuin tekstin kirjoittamisen.
Pystyykö tuon tuplaklikkaus-mahdollisuuden I-sarakkeessakin estämään koodissa? Luonnollisesti siten, että alkueräinen ominaisuus säilyy.
En huomannut laittaa tätä toivetta edelliseen messuuni. :o)

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
Range("G" & Target.Row) = Now()
ThisWorkbook.Save
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 = "" Then
Range("H" & Target.Row) = Now()
Range("J" & Target.Row) = "PÄIVITÄ"
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 & ":H" & 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) = ""
End If
End If

Application.EnableEvents = True
End Sub

Keep EXCELing
@Kunde

Malttamattomana odotin, että pääsin töihin ottamaan käyttöön viimeisimmän päivityksen. Tämä on taas Kunde Ison kiitoksen paikka!
Saas nähdä ilmaantuuko ihan äkkiä uutta viilattavaa. :))
Kiitos!

Nyt menee lujaa.. pari toivetta ilmaantui taas. ;D
1. Toive:
Eli.. jos A-sarakkeen solussa ei ole mitään (eli tyhjä) ei I-sarakkeeseen tahallaan tai vahingossa kirjoitettu nimi aiheuta H-sarakkeessa päivämäärän( ajan) tuloa, eikä J-sarakkeessa Päivitä-tekstin tuloa. Voi kuulostaa turhilta, mutta haluan ettei ns. huti- tai hupitestailut aiheuta Taul3:n historialokiin turhia tyhjiä rivejä.
2. Toive:
Kun A-sarakkeen solu tyhjenee, onnistuuko samalla komennolla poistamaan sen punakolmio-kommentin samasta solusta, jos siinä on sellainen?
Onnistuuko Kunde? (tiedän.. oli tyhmä kysymys -onnistuu varmaan. ;)

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
Range("G" & Target.Row) = Now()
ThisWorkbook.Save
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 & ":H" & 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("A" & Target.Row).Comment.Delete
End If
End If

Application.EnableEvents = True
End Sub

Keep EXCELing
@Kunde

Kyllä tämä työkirja alkaa olla pian täydellinen! :D Suuri kiitos taas Kunde!
En usko, että tarvitsen tuota " ' hipsaa seuraava rivi, jos et halua, että I- sarakkeen solu tyhjenee hutitilanteessa" -mahdollisuutta. En itse asiassa kait hokannut sen syvintä olemusta.. ;D -voisitko avata sitä hieman. *päästä jo muutenkin sekaisin..*
Löysin vielä yhden "tuplaklikkaus-herjan" eli, jos tahallaan tai tahattomasti tuplaklikkaa tyhjää A-saraketta saa se aikaan G-sarakkeessa aiheettoman päivämäärä-aika -infon. Homman saa kyllä palautettua tyhjentämällä aiheettoman pvm-aika -infon. Paras olisi, jos tuplaklikkaus ei aiheuttaisi infoa G-sarakkeessa.
Olisiko kohtuullinen toive? :DD

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

niin ajattelin tyhjätä sen ilman pyyntöä ja jätin varalle jos et halua tyhjentää solua ;-)

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()
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 & ":H" & 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("A" & Target.Row).Comment.Delete
End If
End If

Application.EnableEvents = True
End Sub

Keep EXCELing
@Kunde

Hienoa, jälleen kiitos Kunde!
En voi olla vielä kysymättä yhtä pientä ominaisuutta ja viilailua..
Tämä työkirja, johon teet näitä päivityksiä on jatkuvassa käytössä ja siihen on kerääntynyt matkan varrella jo paljon ns. työtietoa.
A-sarakkeella on myös vanhaa tietoa (jo ennen tätä kiihkeää "päivitysrumbaa") eikä G-sarakkeella siten ole välttämättä sen aikaisia pvm aika-tietoja, ei edes käsin kirjoitettuna.
Tuplaklikkaamalla A-saraketta niille wanhoillekin riveille saisi tietty uuden pvm ajan, mutta se ei ole oikeaa tietoa.
Kysynkin, pystyykö A-sarakkeen tahattoman tai tahallisen tuplaklikkauksen estämään, ettei wanhan tiedon riville tulisi väärää pvm aika -tietoa?
Tässä pähkinänkuoressa toiveeni tällä erää. :)

Alla nykyinen hieman modaamani koodisi.

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()
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) = ""
End If
End If
Application.EnableEvents = True
End Sub

Tässä oikea koodi, edellinen oli vajaa..

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()
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