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
10
254
Vastaukset
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
- 1723264
Kun viimeksi kohtasitte/näitte
Mitä olitte tekemässä? Millainen ympäristö oli? Löydetään toisemme...1392137Olet kyllä vaarallisen himokas
Luova, kaunis, määrätietoinen, pervo, mielenkiintoinen, kovanaama, naisellinen ja erikoinen.1112116- 921915
Anna vielä vähän vihreää valoa
Teen sitten siirtoni, nainen. Tiedän, että olet jo varovaisesti yrittänyt lähestyä, mutta siitä on jo aikaa. Jos tunnet271633- 841630
Miksi homous puhuttaa konservatiiveja vuodesta toiseen?
Kysymykseen on vastattukin Kansanlähetyksen osalta: "Miksi sukupuoleen ja seksuaalisuuteen liittyvät asiat ovat konserv2851144- 2271140
- 721138
- 74968