Löysin nimimerkki Kunden ratkaisun erääseen itseänikin askarruttaneeseen pulmaan (http://keskustelu.suomi24.fi/node/5055889) Sovelsin koodia omiin tarpeisiini, mutta ruokahalu kasvoi syödessä, enkä onnistunut muokkaamaan koodia tarpeeksi.
Olisin kiitollinen, jos Kunde (tai joku muu) voisi jalostaa koodia siten, että taulukon nimen sijaan makro käsittelisi kulloinkin avoinna olevaa taulukkoa ja vastaus tulisi uuteen taulukkoon. Näin makro olisi yleispätevämpi.
Lisäarvoa tulisi myös siitä, että taulukon sarakenimet kopioituisivat transponoitujen arvojen vasemmalla olevaan sarakkeeseen.
Kiitos
Koodien jalostusta
Tuunattua koodia
10
284
Vastaukset 10
en tiedä ymmärsinkö oikein, ja mitä niistä koodeista olis pitänyt muokata(muokkasin nyt ekaa versiota)?
Nyt aktiivinen taulukko kopioituu aina aina uuteen taulukkoon, joka lisätään loppuun
"Lisäarvoa tulisi myös siitä, että taulukon sarakenimet kopioituisivat transponoitujen arvojen vasemmalla olevaan sarakkeeseen."
Tota en ymmärtänyt...
Sub Transponoi()
Dim vika As Integer
Dim solu As Range
Dim originaali As Worksheet
Dim uusi As Worksheet
Set originaali = ActiveSheet
vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
For Each solu In Worksheets(originaali.Name).Range("A1:A" & vika)
solu.Resize(1, 11).Copy
Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Application.CutCopyMode = False
End Sub
Keep EXCELing
@Kunde- Tuunattua koodia
Hienosti toimii, juuri niinkuin halusin.
"Lisäarvoa tulisi myös siitä, että taulukon sarakenimet kopioituisivat transponoitujen arvojen vasemmalla olevaan sarakkeeseen."
Tuo koodi listaa sarakeotsikot transponoidun luettelon alkuun. Haluaisin niin, että ne kopioituisivat niiden arvojen viereen vasemmanpuoleiseen sarakkeeseen.
Alkuperäistä esimerkkiä mukaellen:
Tulos 10
Sukunimi Aaltonen
Etunimi Anssi
Osoite Alkutie 1
Tulos 9
Sukunimi Heikkinen
Etunimi Heikki
Osoite Hämeentie 1
Tulos 9
jne jne Tuunattua koodia kirjoitti:
Hienosti toimii, juuri niinkuin halusin.
"Lisäarvoa tulisi myös siitä, että taulukon sarakenimet kopioituisivat transponoitujen arvojen vasemmalla olevaan sarakkeeseen."
Tuo koodi listaa sarakeotsikot transponoidun luettelon alkuun. Haluaisin niin, että ne kopioituisivat niiden arvojen viereen vasemmanpuoleiseen sarakkeeseen.
Alkuperäistä esimerkkiä mukaellen:
Tulos 10
Sukunimi Aaltonen
Etunimi Anssi
Osoite Alkutie 1
Tulos 9
Sukunimi Heikkinen
Etunimi Heikki
Osoite Hämeentie 1
Tulos 9
jne jneoletuksena otsikot ekalla rivillä ja 4 saraketta tietoa.
helppo muutella toki...
Sub Transponoi()
Dim vika As Integer
Dim solu As Range
Dim originaali As Worksheet
Dim uusi As Worksheet
Set originaali = ActiveSheet
vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
For Each solu In Worksheets(originaali.Name).Range("A2:A" & vika)
solu.Resize(1, 11).Copy
Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Range("A2").Select
For i = 1 To vika - 1
Worksheets(originaali.Name).Range("A1:D1").Copy
Worksheets(taulukko.Name).Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Application.CutCopyMode = False
End Sub
Keep EXCELing
@Kunde- Tuunattua koodia
kunde kirjoitti:
oletuksena otsikot ekalla rivillä ja 4 saraketta tietoa.
helppo muutella toki...
Sub Transponoi()
Dim vika As Integer
Dim solu As Range
Dim originaali As Worksheet
Dim uusi As Worksheet
Set originaali = ActiveSheet
vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
For Each solu In Worksheets(originaali.Name).Range("A2:A" & vika)
solu.Resize(1, 11).Copy
Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Range("A2").Select
For i = 1 To vika - 1
Worksheets(originaali.Name).Range("A1:D1").Copy
Worksheets(taulukko.Name).Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Application.CutCopyMode = False
End Sub
Keep EXCELing
@KundeKiitos paljon Kunde. :))
- Tuunattua koodia
Tuunattua koodia kirjoitti:
Kiitos paljon Kunde. :))
Lähtötaulukoissa on vain 16 riviä, mutta jokaisella on ns.indeksinimi A-sarakkeessa. Olisiko vielä mahdollista saada tämä indeksinimi kopioitumaan kohdetaulukon A-sarakkeeseen kunkin edellä kopioidun rivin kohdalle. Edellä mainitut tiedot olen sijoittanut sarakkeisiin B ja C. Homma on työlästä ja tarkkaavaisuutta vaativaa tehdä manuaalisesti, sillä sarakkeiden määrä lähtötaulukoissa vaihtelee (25-31).
Kiitos vielä. Tuunattua koodia kirjoitti:
Lähtötaulukoissa on vain 16 riviä, mutta jokaisella on ns.indeksinimi A-sarakkeessa. Olisiko vielä mahdollista saada tämä indeksinimi kopioitumaan kohdetaulukon A-sarakkeeseen kunkin edellä kopioidun rivin kohdalle. Edellä mainitut tiedot olen sijoittanut sarakkeisiin B ja C. Homma on työlästä ja tarkkaavaisuutta vaativaa tehdä manuaalisesti, sillä sarakkeiden määrä lähtötaulukoissa vaihtelee (25-31).
Kiitos vielä.laita esimerkki kopioitavasta datasta ja miten se pitää saada uuteen taulukkoon, helpottaa suunnattomasti ;-)
- Tuunattua koodia
kunde kirjoitti:
laita esimerkki kopioitavasta datasta ja miten se pitää saada uuteen taulukkoon, helpottaa suunnattomasti ;-)
Taulukossa on 16 riviä ja 25-31 saraketta
1980 1981 1982 1983 1984 1985 -- --
Fin 20 21 22 15 18 19
Swe 21 22 23 17 18 20
Dan 25 18 14 23 22 15
--
--
Haluttu tulos olisi allaolevan kaltainen
Fin 1980 20
Fin 1981 21
Fin 1982 22
Fin 1983 15
Fin 1984 18
Fin 1985 19
Swe 1980 21
Swe 1981 22
Swe 1982 23
Swe 1983 17
Swe 1984 18
Swe 1985 20
Dan 1980 25
Dan 1981 18
Dan 1982 14
Dan 1983 23
Dan 1984 22
Dan 1985 15 Tuunattua koodia kirjoitti:
Taulukossa on 16 riviä ja 25-31 saraketta
1980 1981 1982 1983 1984 1985 -- --
Fin 20 21 22 15 18 19
Swe 21 22 23 17 18 20
Dan 25 18 14 23 22 15
--
--
Haluttu tulos olisi allaolevan kaltainen
Fin 1980 20
Fin 1981 21
Fin 1982 22
Fin 1983 15
Fin 1984 18
Fin 1985 19
Swe 1980 21
Swe 1981 22
Swe 1982 23
Swe 1983 17
Swe 1984 18
Swe 1985 20
Dan 1980 25
Dan 1981 18
Dan 1982 14
Dan 1983 23
Dan 1984 22
Dan 1985 15helppoahan se nyt oli kun sai selkeät ohjeet...
fiksasin nyt vielä siten, että huomioi automaattisesti sarakkeiden määrän
Sub Transponoi()
Dim vika As Integer
Dim vika2 As Integer
Dim solu As Range
Dim i As Integer
Dim j As Integer
Dim originaali As Worksheet
Dim uusi As Worksheet
Set originaali = ActiveSheet
vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
vika2 = Range("IV1").End(xlToLeft).Column
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
For Each solu In Worksheets(originaali.Name).Range("B2:B" & vika)
solu.Resize(1, vika2).Copy
Worksheets(taulukko.Name).Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Range("A2").Select
For i = 1 To vika - 1
Worksheets(originaali.Name).Range("B1").Resize(1, vika2).Copy
Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
For i = 1 To vika - 1
For j = 1 To vika2 - 1
Worksheets(originaali.Name).Range("A" & i 1).Copy Worksheets(taulukko.Name).Range("A65536").End(xlUp).Offset(1, 0)
Next
Next
Application.CutCopyMode = False
End Sub
Keep EXCELing
@Kunde- Tuunattua koodia
kunde kirjoitti:
helppoahan se nyt oli kun sai selkeät ohjeet...
fiksasin nyt vielä siten, että huomioi automaattisesti sarakkeiden määrän
Sub Transponoi()
Dim vika As Integer
Dim vika2 As Integer
Dim solu As Range
Dim i As Integer
Dim j As Integer
Dim originaali As Worksheet
Dim uusi As Worksheet
Set originaali = ActiveSheet
vika = Worksheets(originaali.Name).Range("A65536").End(xlUp).Row
vika2 = Range("IV1").End(xlToLeft).Column
Set taulukko = Worksheets.Add(after:=Worksheets(Worksheets.Count))
For Each solu In Worksheets(originaali.Name).Range("B2:B" & vika)
solu.Resize(1, vika2).Copy
Worksheets(taulukko.Name).Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
Range("A2").Select
For i = 1 To vika - 1
Worksheets(originaali.Name).Range("B1").Resize(1, vika2).Copy
Worksheets(taulukko.Name).Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next
For i = 1 To vika - 1
For j = 1 To vika2 - 1
Worksheets(originaali.Name).Range("A" & i 1).Copy Worksheets(taulukko.Name).Range("A65536").End(xlUp).Offset(1, 0)
Next
Next
Application.CutCopyMode = False
End Sub
Keep EXCELing
@KundeKun sen osaa, niin sen osaa. Nyt alkuperäinen koodi on tuunattu niin, ettei sitä samaksi uskoisi. Kiitos Kunde.
Tuunattua koodia kirjoitti:
Kun sen osaa, niin sen osaa. Nyt alkuperäinen koodi on tuunattu niin, ettei sitä samaksi uskoisi. Kiitos Kunde.
KIITOS
The worst day with VBA is better than the best day at work!
Ketjusta on poistettu 0 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
Mikä on totta mikä ei?
Onko juoru vai ei että nimeltä mainitsematon henkilö on tehnyt naiselle/naisille jotain joka on väärin?212294Päivän aivopieru Trumpilta
Trump julisti sodan hyttysiä vastaan. Myös punkit ovat Trumpin sodan kohteena. Eikö vieläkään USA:n kansa tajua tuon uko861526- 132968
Just saying
Mies joka antaa naiselle turvallisen olon, on seksikäs. Ei kieroja kikkoja ja haluaa olla vain sen yhden naisen mies.142745Löytyikö syy miksi Martina on Muhiksen kanssa
Saipa naurut Gekkosen kuvasta, missä ovat ravintola Hookissa Immu fight night ottelun jälkeen, Muhoksella pullottaa hirv95682- 54676
- 13637
Jorma Uotinen läväytti härskin heiton - Paljastus uudesta TTK-romanssista?
Tuomari Jorma Uotisen linja on välillä hyvinkin rohkea TTK:ssa. Hän näpäytti Jaakko Parkkalille ja Kastanja Rauhalalle v12608Jos selviäisi että kaivattusi
Olisi savant asperger? Rakastaisitko vielä? Savant-lahjakkuus olisi kapea-alaista neroutta liittyen mekanisiin ja tilan96602On väärin
Tykätä ja haluta sua kun tilanne täysin mahdoton mutta minkäs teet. Mun sisällä roihuaa 🔥 kunpa tietäisit mitä sä minus42562- 65561
Toivotko vielä viestiä
Minulta? En rohkene enää ottaa yhteyttä, kun varmasti jo uusia naisia elämässä. Nolaisin vain itseni.44559Jokin ei täsmää
Joskus yksi vuosiluku saa katsomaan koko tarinaa uudestaan. Löysin gradun. Matematiikka ei oikein täsmää siihen, mitä mi298556- 42525
- 138521
Älä unohda minua
Nainen ethän unohda minua. Asiat olisivat voineet mennä toisin, olisi vain pitänyt uskaltaa lähestyä sinua kun annoit si66509Oliko Jani Halmeen aika jo tippua TTK:sta?
Jani Halme ja Claudia Ketonen joutuivat jättämään TTK:n. Halme ja Ketonen saivat viimeiseksi jäänestä tanssista, sambas28508- 77504
Kuka kaipaa T m?
Kerro nainen kirjaimesi vaan... Haluan miettiä kuka tulee ekana mieleeni.. kuin kurkistus tunteiden meren pinnalle, jota36500Miksi jotku naiset on niin tyhmiä
Että elättelevät turhaa toivoa toisen kustannuksella. Onko ne kaikki kaappilesboja vai mikä niitä vaivaa? Sitten itketä54498