Otin tämän vanhan makron käyttöön ja olen sen saanut toimimaan sen verran hyvin että ainoa vika taitaa olla jos on sama erä eri vuosille niin se korjaa aikaisemman vuoden erän?
Sub Kopioi()
Dim vika As Integer
Dim Haettava As Range
Dim Haettava2 As Range
Dim Hakualue As Range
Dim Löydetty As Range
Dim EkaSolu As String
Sheets("Syöttö").Activate
Set Haettava = Range("M9")
Set Haettava2 = Range("O6")
Sheets("Data").Activate
vika = Range("B65536").End(xlUp).Row
Set Hakualue = Range("B1:B" & vika)
Range("B1").Select
Set Löydetty = Hakualue.Find(What:=Haettava, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False)
If Not Löydetty Is Nothing Then
EkaSolu = Löydetty.Address
If Löydetty.Offset(0, 3) = Haettava2 Then
msg = "Erä on jo olemassa_1! " & "Haluatko tallentaa vanhan päälle!"
response = MsgBox(msg, vbYesNo)
If response = vbYes Then Range(EkaSolu).Offset(0, 1) = Sheets("Syöttö").Range("I9") Else Exit Sub
Range(EkaSolu).Offset(0, 2) = Sheets("Syöttö").Range("D9")
Range(EkaSolu).Offset(0, 4) = Sheets("Syöttö").Range("A13")
Exit Sub
Else
Do
Set Löydetty = Hakualue.FindNext(Löydetty)
If Löydetty.Offset(0, 3) = Haettava2 Then
msg = "Erä on jo olemassa_2! " & "Haluatko tallentaa vanhan päälle!"
response = MsgBox(msg, vbYesNo)
If response = vbYes Then Range(EkaSolu).Offset(0, 1) = Sheets("Syöttö").Range("I9") Else Exit Sub
Range(EkaSolu).Offset(0, 2) = Sheets("Syöttö").Range("D9")
Range(EkaSolu).Offset(0, 4) = Sheets("Syöttö").Range("A13")
Exit Sub
End If
Loop While Not Löydetty Is Nothing And Löydetty.Address EkaSolu
Range("B" & vika 1) = Haettava
Range("B" & vika 1).Offset(0, 3) = Haettava2
Call tallennatiedot(vika)
End If
Else
Range("B" & vika 1) = Haettava
Range("B" & vika 1).Offset(0, 3) = Haettava2
Call tallennatiedot(vika)
End If
End Sub
Siirsin tämän ylemmäksi
2
286
Vastaukset
- kyselijä
Tämä viestiketju on tuolla alempana "11032006 kysytty" nimellä mutta ajattelin sen menevän kohta piiloon enkä saa siihen sitten vastausta, joten siirsin sen tähän ylemmäksi.
Makron piti hakea tietoa Syöttö lehdeltä ja tarkistaa että Data lehdellä ei ole vastaavia tietoja Erän ja Vuoden mukaan jos on niin kysyy tallennetaanko päälle , muuten tallentaa tiedot Data lehdelle.- kyselijä
(varmaankin jotain virheitä / päälekkäisyyksiä makrossa on?) muuten hyvä mutta jos tiedot on jo olemassa ja vastaa ei korvataanko kysymykseen niin se tulee makrosta pois ja jättää data sivun esille , hyvä mutta se jää data sivun yläreunaan pitäisi saada jäämää siihen kohtaan missä tiedot on?
Sub erantallennus()
Dim vika As Integer
Dim Haettava As Range
Dim Haettava2 As Range
Dim Hakualue As Range
Dim Löydetty As Range
Dim EkaSolu As String
Dim TokaSolu As String
Sheets("Syöttö").Activate
Set Haettava = Range("M9")
Set Haettava2 = Range("O6")
Sheets("Data").Activate
vika = Range("B65536").End(xlUp).Row
Set Hakualue = Range("B1:B" & vika)
Range("B1").Select
Set Löydetty = Hakualue.Find(What:=Haettava, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False)
If Not Löydetty Is Nothing Then
EkaSolu = Löydetty.Address
If Löydetty.Offset(0, 3) = Haettava2 Then
msg = "Erä on jo olemassa! " & "Haluatko tallentaa vanhan päälle!"
response = MsgBox(msg, vbYesNo)
If response = vbYes Then Range(EkaSolu).Offset(0, 1) = Sheets("Syöttö").Range("I9") Else Exit Sub
Range(EkaSolu).Offset(0, 1) = Sheets("Syöttö").Range("D9")
Range(EkaSolu).Offset(0, 2) = Sheets("Syöttö").Range("I9")
Sheets("Syöttö").Activate
MsgBox "Muista tallentaa myös koko tiedosto!"
Exit Sub
Else
Do
Set Löydetty = Hakualue.FindNext(Löydetty)
If Löydetty.Offset(0, 3) = Haettava2 Then
TokaSolu = Löydetty.Address
msg = "Erä on jo olemassa! " & "Haluatko tallentaa vanhan päälle!"
response = MsgBox(msg, vbYesNo)
If response = vbYes Then Range(TokaSolu).Offset(0, 1) = Sheets("Syöttö").Range("I9") Else Exit Sub
Range(TokaSolu).Offset(0, 1) = Sheets("Syöttö").Range("D9")
Range(TokaSolu).Offset(0, 2) = Sheets("Syöttö").Range("I9")
Sheets("Syöttö").Activate
MsgBox "Muista tallentaa myös koko tiedosto!"
Exit Sub
End If
Loop While Not Löydetty Is Nothing And Löydetty.Address EkaSolu
Range("B" & vika 1) = Haettava
Range("B" & vika 1).Offset(0, 3) = Haettava2
Call tallennatiedot(vika)
MsgBox "Muista tallentaa myös koko tiedosto!"
End If
Else
Range("B" & vika 1) = Haettava
Range("B" & vika 1).Offset(0, 3) = Haettava2
Call tallennatiedot(vika)
MsgBox "Muista tallentaa myös koko tiedosto!"
End If
End Sub
Ketjusta on poistettu 0 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
Perussuomalaiset kirjoittaa vain positiivisista uutisista
Ei tarvitse palstaa paljon seurata, kun sen huomaa. Joka ainoa positiivinen uutinen Suomen taloudesta tai ylipäätään, ni1096606Kuka on UMK-suosikkisi? UMK26 paljastuksia lauantai 28.2.
UMK26 tänä lauantaina! UMK26 tulee suorana Tampereelta ja nyt selviää, kuka pääsee edustamaan Suomea Euroviisuihin. M884241L/over ja Jani Volanen! Minkä arvosanan 4-10 annat roolityöstä?
Psykologinen trilleri L/over - ikuisesti minun on koukuttanut tv-katsojat ruudun ääreen. Kun Roosa (Krista Kosonen) tapa453559TTK:n jättänyt Vappu Pimiä rehellisenä MasterChef-kuvauksista: "Höh..."
Vappu Pimiä on uusi MasterChef Suomi -tuomari. Viime vuonna Tanssii Tähtien Kanssa jäi taakse, ja nyt vuorossa on uusi a72941Natomaa hyökkäsi Iraniin
Näemme nyt tällä hetkellä Natomaan nimeltä Yhdysvallat, joka toimii aika pitkälti perinteisen kansainvälisen lain ulkopu6251551- 66978
Rakas tiedät, että toivoisin
Kuulevani sinusta. Tiedät, että viestisi tekisi minut ihan onnelliseksi. Että äänesi kuuleminen saisi minut leijumaan ja55953- 9939
Trump aloitti III maailmansodan tänään.
Narsisti ja mielipuoli Trump pitäisi saada pois, miten se onnistuisi parhaiten?193918Osaako kukaan sanoa?
Mikä on syy siihen, että apulaisidiootti yrittää kaikin keinoin haitata kaikkea yrittämistä Ähtärissä? Nyttkin pilkkaa j47899