Koodien jalostusta

Tuunattua koodia

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

10

269

Äänestä

    Vastaukset

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • kunde

      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

      • kunde
        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 jne

        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
        @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
        @Kunde

        Kiitos 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ä.

      • kunde
        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

      • kunde
        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 15

        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
        @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
        @Kunde

        Kun sen osaa, niin sen osaa. Nyt alkuperäinen koodi on tuunattu niin, ettei sitä samaksi uskoisi. Kiitos Kunde.

      • 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ä.

    Takaisin ylös

    Luetuimmat keskustelut

    1. Maatalous- ja yritystuet pois, työeläkevaroilla valtion velka pois

      Suomi saadaan eheytettyä kädenkäänteessä, kun uskalletaan tehdä rohkeita ratkaisuja. Maatalous- ja yritystuet ovat hait
      Maailman menoa
      150
      4029

    2. Hei! Halusin vain kertoa.

      En tiedä luetko näitä, mutta näimme n.4vk sitten, vaihdoimme muutaman sanan ja tunsin edelleen kipinän välillämme. Katso
      Tunteet
      15
      3909

    3. Miksi ikävä ei helpotu vuosien jälkeenkään?

      Tänään olin ensimmäistä kertaa sinun lähtösi jälkeen tilassa, jossa vuosia sitten nähtiin ensimmäistä kerta. Ollessani
      Rakkaus ja rakastaminen
      12
      3052

    4. Riikka on siis suomalaisille velkaa 84 mrd

      Jos kauhukabinetti istuu vaalikauden loppuun. Keskimäärin yli 20 miljardia uutta velkaa rikkaiden veronalennuksiin jokai
      Maailman menoa
      66
      3038

    5. Sanna on suomalaisille siis velkaa 24 mrd euroa

      Muistanette vielä kuinka Italian remonttirahoja perusteltiin sillä, että italialaiset ostaa suomalaisilta paidatkin pääl
      Maailman menoa
      149
      2602

    6. Teboili alasajo on alkanut

      Niinhän siinä kävi että teebboili loppuu...
      Suomussalmi
      71
      2510

    7. Luotathan siihen tunteeseen, joka välillämme on?

      Uskothan myös, että se kestää tämän? Kaipaan sinua valtavasti. Vielä tehdään yhdessä tästä jotain ihmeellistä ja kaunist
      Ikävä
      28
      2223

    8. Pystyisitkö pitämään

      Näppejä erossa jos tulisi siihen tilaisuus
      Ikävä
      30
      1619

    9. "Sanna Marinin kirja floppasi", kertoo eräs median otsikko

      "Miljardien tappio - Sanna Marin vaikenee", kertoo toinen otsikko. Marin ei siis siinä kirjassaan kerro sanallakaan For
      Maailman menoa
      114
      1554

    10. Tuntuuko ettet tiedä

      Enää miten toimia mun suhteen. Kun en taida tietää itsekään
      Ikävä
      20
      1405
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt