Olisi tarve saada yhdestä yksinkertaisesta varasto-Excelin tapahtumista jonkunlainen historiakertymä aikaiseksi. En tarkasti ottaen itsekään vielä tiedä minkälainen olisi hyvä, mutta yritän valaista tarvetta.
Varastossa on esim.
A-hyllyrivi
1-pystyrivi
1-taso
-eli hyllypaikkaosoite esimerkissä: A-1-1.
Tuolla kyseisellä hyllypaikkaosoitteella (A-1-1) voi tavara vaihtua useammankin kerran kuukaudessa, joskus jopa päivittäin.
Haluaisin toteuttaa tuossa excelissä jonkunlaista historiakertymää kyseiselle hyllypaikkaosoitteelle, jolloin pääsisi näkemään mitä artikkeleita tuon paikan kautta on kiertänyt ja minä päivinä.
-(esimerkkiartikkeleita joita kiertää tuolla paikalla on: jumpperit, liittimet, adapterit)-
Jatkossa tulisin tekemään mallin mukaisesti muillekin hyllypaikkaosoitteille tuon historiakertymän.
1. Vaihtoehto
Välilehdelle 2. kerätääntyy historiatiedot siten, että esim. soluihin A1-A1000 kerääntyisi artikkelit ja soluihin B1-B1000 kerääntyisi tapahtuman päivämäärät .
Välilehdellä 1. olisi varsinaiset hyllypaikkojen osoitteet eli solut, joihin uusin tapahtuma kirjataan ja välilehdelle 2. siirtyisi tuo historiakertymä.
2. Vaihtoehto
Tapahtumat kirjattaisiin välilehdellä 1 soluun A1, josta se siirtyisi historiasoluun A2.
Esim. hyllypaikkaosoitteessa A-1-1 (solussa A2) -olisi alaspudotusvalikko, johon historia kerääntyisi, ylimmäiseksi se viimeisin eli uusin tapahtuma.
A1 = Artikkelinyöttösolu, B1 = pvm (automaattisesti syöttöpäivämäärä)
Historian pituudeksi riittäisi 1000 riviä, eli kattaa lähes 1/2 vuotta käytännössä.
Saikohan tuosta mitään tolkkua.
Varastohistorian luominen
101
135
Vastaukset
- sillaikait
En osaa tossa auttaa, mut täällä pitäisi olla jonkun aiempi kyssäri samasta aiheesta. Harmi vaan, ettei täällä ole enää hakukenttää millä etsiä. Ootko ton kunden sivuilla käyny? http://www.kundepuu.com/viewforum.php?f=155
- Riittoa
Kävin Kunden sivulla.. aika kova etsiminen. En toistaiseksi löytänyt osumaa aiheesta. Kiitos osoitteesta.
- Tämmöinen
Vaihtoehto 2.
Seuraava makro siirtää historiaa alaspäin ja kopioi solujen A1 ja B1 arvot 2-riville aina kun solun A1 sisältö muuttuu (= kaavarivillä painetaan enteriä - arvo voi pysyä samanakin). Solussa B2 on kaava =NOW(). B-sarakkeen muotoilun pitää olla päivämäärä (tai päivämäärä ja aika).
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err
Application.EnableEvents = False
If (Not Intersect(Range("A1"), Target) Is Nothing) Then
Rows(2).Insert
Range("A2:B2") = Range("A1:B1").Value
End If
Err:
Application.EnableEvents = True
End Sub - Riittoa
Kiitos. En saanut tuota toimimaan kuvaamallasi tavalla. Mielestäni tein kaiken oikein VB:ssä..
Onko kukaan muu testannut tämän toimivuutta?- Tämmöinen
Makroa ei pidä laitaa moduliin, vaan se on kyseisen sivun koodia.
- Riittoa
En laittanut sitä moduliin. Onko väliä onko makro työkirjassa vai taulussa?
- Tämmöinen
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
- Riittoa
Nyt sain toimimaan, hieman kokeiltuani. Hienoa!
Alkuperäinen toiveeni oli, että saisin tuon tapahtumahistorian kerääntymään toiselle (Taul2) välilehdelle. Onnistuuko helposti?- Tämmöinen
Worksheets("Taul2").Rows(2).Insert
Worksheets("Taul2").Range("A2:B2") = Range("A1:B1").Value
. - Riittoa
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
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.Korjaus:
Siis Miten onnistuu kopioida Taul1 (A2:B2) solujen tieto => Taul2 (A3:B3) :een, samassa VB koodissa? - tuputin_huono
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
- Grouzet
Kiinnostava aihe, olisi itsellänikin käyttöä tuolle idealle. Miten tuota voisi modata, kun tarpeeni olisi seuraava.
Esimerkin valossa rivillä A1-G1 kaikissa soluissa on vaihtuvaa tietoa. Miten saan tiedon säilymään toisella sivulla siten, ettei se häviä. Eli toisella sivulla olisi ns.loki ekan sivun tapahtumista. Hieman kuten aiheen aloittajakin haluaa.
En tiedä onnistuuko muodostaa lokeja useammasta rivistä eli A2-G2.....A100-G100?- Tämmöinen
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 - Kundepuu
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 ;-) - Grouzet
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"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.
- Grouzet
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 ;-)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? :)
- Tämmöinen
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.
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 - Grouzet
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 SubMeni 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. :) - Kundepuu
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 - Grouzet
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. - Kundepuu
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
- Grouzet
Aivan mahtavaa.. Suurkiitos Kunde! Sain kuin sainkin tuon toimimaan juuri niin kuin sen pitääkin. Pääsen omissa kuvioissani tällä eteenpäin, kunhan hion nimet ja rivimäärät tarpeisiini sopiviksi.
- Grouzet
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ä? - Kundepuu
tottakai ;-)
Keep EXCELing
@kunde - Grouzet
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. :)) - Kundepuu
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 - Kundepuu
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 - Grouzet
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 - Kundepuu
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 - Grouzet
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. - Kundepuu
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 - Grouzet
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. - Kundepuu
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 - Grouzet
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.
- Grouzet
Korjaus!
Kelpoisuusalueen lähde on siis Sheet3:lla, eikä Sheet2:lla.
Tein onnistuneen kokeilun noilen alaspudotusvalikoiden kanssa, se onnistuikin omin voimin.
Tästä on hyvä mennä eteenpäin.
Suuret kiitokset vielä avusta Kunde!- Grouzet
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? - Kundepuu
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
- Grouzet
Kiitos Kundepuu, otan ja kokeilen tuota.
Aurinkoista vkla! - Burgund
Oma toiveeni noudattaa melkein "Grouzet":n toivetta. Onnistuisiko seuraava?
Duunipalvelimella (esim.X:\) on välillä suljettu, välillä auki oleva tiedosto.xlsx, josta itsekin haluaisin (Taul1) sarakkeiden A-I riveiltä 2-200 muuttuneiden rivien tietojen kopioituvan omalle työkoneelleni siten, että omalla koneellani auki oleva tiedosto historialoki.xlsx hakisi määräajoin palvelimelta muuttuneet rivitiedot ja pitäisi yllä samanlaista 5:n rivin historialokia kuin nimimerkin "Grouzen" mallissa on. Yksi oleellinen asia tässä on se, ettei palvelimen excel-tiedostolle asenneta mitään vb-koodia, vaan oma tiedostoni hakisi muuttuneet tiedot. Lokin päivitys pitäisi saada automaattiseksi ilman napin painamista ja rivin/sarakkeen kyselyä. Olisiko "Mahdoton tehtävä"?- Kundepuu
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
- Burgund
En saa tuota toimimaan, eli jokin mulla on pakko olla väärin.
Lähtötilantessani on (lähde)tiedosto servulla polulla X:\polku\tiedosto.xlsx ja omalla koneellani C:\polku\varmuuskopio.xlsx. (tyhjä varmuuskopio.xlsx on tallennettu makrot hyväksyen)
Välillä pidän Varmuuskopio -tiedostoa auki ja välillä kiinni -olettaen ettei anna kirjoittaa, jos on auki.
Alla toimenpiteeni koodistasi Kundepuu.
Tallennettu: "TämäTyökirja" 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
Tämän Taul1 moduuliin:
Option Explicit
------------------------------------------------------------------------------
Sub Varmuuskopio()
ThisWorkbook.Worksheets("Sheet1").Range("A:I").ClearContents
GetData "X\polku\tiedosto.xlsx", "Taul1", "A1:I200", Sheets("Taul1").Range("A1")
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- Kundepuu
Suorita makro VArmuuskopio rivi riviltä. Tuleeko virheilmoitusta ?
Kunde - Kundepuu
Huomasin juuri, että olet kopioinut koodin Taul1 moduuliin, etkä tavalliseen moduuliin(INSERT/MODULE)...
siinäpä se syy lienee.
Keep EXCELing
@Kunde
- Burgund
Terve. Joku mättää tekemisissäni.
En tiedä miten tämä suoritetaan rivi kerrallaan. Herjoja tuli jokaisella kerralla kun painoin makron suoritusta. Mm.. Sub Auto_Open() tuli keltaisella.
Tallennettu "TämäTyökirja" :aan.
Sub Auto_Open()
Varmuuskopio
End Sub
------------------------------------------------------------------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime Now(), "Varmuuskopio", , False
End Sub
Nyt on pakko kysyä; Mistä löytyy tavallinen moduuli? Kokeilin: VBAProject(Varmuuskopio.xlsm)/INSERT/MODULE -sinne laitoin:
Option Explicit
------------------------------------------------------------------------------
Sub Varmuuskopio()
ThisWorkbook.Worksheets("Taul1").Range("A:I").ClearContents
GetData "X\polku\tiedosto.xlsx", "Taul1", "A1:I200", Sheets("Taul1").Range("A1")
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- Kundepuu
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 - Burgund
Kiitos vastauksesta Kunde. Yritän ratkaista dilemmaani mahd. pian. Vaivaan taas kyllä sinua, jos ei rupea vorkkimaan. :)
- Burgund
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
@KundeDodiin.. 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;" & _ - Burgund
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;" & _ - Kundepuu
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 - Burgund
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
@KundeHarmillista.. 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. - Kundepuu
Mikä veriso Excelistä sulla on?
- Kundepuu
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 - Burgund
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"? - Kundepuu
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 - Burgund
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
@KundeKiitos 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. - Kundepuu
riippuu mitä makro tekee suojaus voi aiheuttaa virheen makron suorituksen tai sit ei ...
mutta koodillahan siitäkin selviää kivuttomasti ;-)
Keep EXCELing
@Kunde
- Burgund
Terve Kunde,
Todella upeaa, että autat näissä pikku ongelmissa. toivottavasti tästä on apua toisillekin.
Viimeisin ongelmani:
"Olisiko muuten tuohon koodiin ollut mahdollista sisällyttää solujen Lisäkommenttien (se punainen kolmio solussa) kopiointiominaisuus "Varmuuskopiolle"?."
-ratkesikin omin voimin. Kyseessä toimimattomuuteen olikin vain testiversioni liian tiukat suojaukset.
Onkohan helppo saada ruudulle ilmestymään omalla tekstilläni herja/ilmoitus tyyliin: "Muistithan tarkistaa sen ja sen!" Tämä saisi tulla joka kerta sulkiessa tiedostoa.- Kundepuu
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 - Burgund
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ä! - Burgund
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 - Kundepuu
toimii riippumatta siitä onko lähdetiedosto auki tai kiinni ja nyt mallisi mukaan 1 min välein suorittaa haun
- Burgund
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ä. - Kundepuu
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 - Kundepuu
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 - Burgund
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!
- Grouzet
Kunde, palaan vielä tuohon mainioon toimivaan koodiisi.
Toivelistalla olisi pieni parannus. Onko mahdollista muuttaa tuo "Siirräenterillä()" -osio puoliautomaattiseksi siten, että "Päivitä" -nappia painamalla se kävisi itse läpi muuttuneet rivit Taul1:llä ja päivittäisi ne Taul3:lle? Nythän täytyy itse muistaa mitkä rivit pitää päivittää ja painaa sitä enteriä. Yhden muutosistunnon aikana saatetaan muuttaa jopa 10-20 riviä, joten päivitä-nappi olisi erittäin suuri toive!
Onko liian hankala toive -helpottaisi mahdottomasti muuten hienosti palvelevaa taulukkoa.
Alla tarpeisiini muokattu ja käytössä oleva koodisi.
Sub teeVarmuuskopio()
Dim Nimi As Name
Dim Rivi As Long
Dim Rivi2 As Long
Dim Rivi3 As Long
With Worksheets("Taul3")
.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
Worksheets("Taul3").Names.Add Name:="Rivi" & Rivi3, RefersToR1C1:="=Taul3!R" & Rivi & "C1:R" & Rivi2 & "C10"
Rivi = Rivi 5
Rivi2 = Rivi2 5
Rivi3 = Rivi3 1
Next
Rivi = 2
Rivi2 = 6
For Each Solu In Worksheets("Taul1").Range("A2:A100")
Solu.EntireRow.Copy Worksheets("Taul3").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("Taul1").Range("J" & Solu.Row) = Now()
Worksheets("Taul3").Range("Rivi" & Solu.Row - 1).Resize(4).Copy Worksheets("Taul3").Range("Rivi" & Solu.Row - 1).Offset(1)
Worksheets("Taul1").Range("A" & Solu.Row & ":J" & Solu.Row).Copy Worksheets("Taul3").Range("Rivi" & Solu.Row - 1).Resize(1)
End If
End Sub- Kundepuu
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 - Grouzet
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
@KundeToimii 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. - Kundepuu
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
- Grouzet
Ihan mainio idea Kunde tuokin, että kirjoittaa L-sarakkeeseen jotain.. jne. Tämä taulukko kun on usean käyttäjän käytössä, niin on suuri riski ettei muisteta joka rivin kohdalla tehdä tuota. Siksi olisikin mainiota ja selkeämpää, että kaikkien rivien solujen muutokset kuitattaisiin (päivitettäisiin) yhdellä "Päivitä" -napinpainalluksella. Noita "Päivitä" -nappeja olisi helppo kopioida vaikka tuolle L-sarakkeelle riittävästi, jotta ne näkyisi skrollattaessa taulukkoa alas/ylöspäin.
Jos tuollainen olisi Kunde mahdollista, niin ilolla ottaisimme ominaisuuden muuten jo hienosti toimivaan taulukkoon käyttöön. Hieno työkalu!- Kundepuu
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 - Grouzet
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? :) - Kundepuu
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 - Grouzet
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. :) - Kundepuu
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 - Grouzet
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
@KundeNo 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. - Kundepuu
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 - Grouzet
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. :)) - Grouzet
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? :)) - Kundepuu
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- Grouzet
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! - Grouzet
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! :)) - Kundepuu
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 - Grouzet
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ä! :) - Grouzet
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 - Kundepuu
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 - Grouzet
Todella hienoa työtä jälleen. Kiitos kovasti Kunde!
Jospa tällä pärjäisin pitkään.. Jää nähtäväksi. ;D
Viikonloppuja! - Grouzet
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. - Kundepuu
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 - Grouzet
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) - Kundepuu
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 - Grouzet
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! - Grouzet
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. ;) - Kundepuu
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 - Grouzet
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 - Kundepuu
" ' 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 - Grouzet
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 - Grouzet
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
- Grouzet
Asia pihvi.. täytyy olla vain tyytyväinen, että kokeiluni toimii edelleen. :]]
Mahtavaa, kun olet selvästikin jopa paneutunut ongelmiini -kuten juuri äskeinen "Päivitä" -visioni. Sekin toimii loistokkaasti.
Olen jotain pientä vielä pyöritellyt mielessäni tähän työkirjaan ja taulukoihin.. Palaan varmasti aiheeseen, mikäli sut saa vielä "lämpenemään" tälle. ;D
Nyt vedän (vedämme) henkeä ja nautimme tästä Loistavasta työkalusta!
Suurkiitos ja hyvää kesää Kunde!
Ketjusta on poistettu 1 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
Mikä on kaivattusi etunimi?
Otsikossa siis on kysymys eriteltynä. Vain oikeat vastaukset hyväksytään.1252295En kestä katsoa
Sitä miten sinusta on muut kiinnostuneita. Olen kateellinen. Siksi pitäisi lähteä pois1031357Peräti 95 % persujen kannattajista rasisteja
Kertoo EVA:n teettämä kysely. Pakollista yhdenvertaisuuskoulutusta tarvitsee siis paljon laajempi joukko kuin pelkästää3191079Kun viimeksi kohtasitte/näitte
Mitä olitte tekemässä? Millainen ympäristö oli? Löydetään toisemme...1041057- 1091051
Olet kyllä vaarallisen himokas
Luova, kaunis, määrätietoinen, pervo, mielenkiintoinen, kovanaama, naisellinen ja erikoinen.86929On minulla suunitelma
Siitä ei vain tiedä kukaan muu kuin tällä hetkellä minä. Suunnitelma ja varasuunnitelma. Sinun takiasi nainen. Vain s44700Palstan ylivoimaisesti suosituin keskustelunaihe
Palstan suosituin keskustelunaihe näyttää olevan homoseksuaalisuus. Otsikoiden perusteella voisi kuvitella olevansa Seks252689Ei koskaan saatu tuntea
Mitä olisi ollut painautua toisiimme vasten. Hengittää syvään, hyväillä ja rakastella vailla kiirettä. Tai repiä vaattee33670- 50664