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

254

Ää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. Anna minulle anteeksi

      Anna minulle anteeksi. Minä pyydän.
      Ikävä
      172
      3264

    2. Kun viimeksi kohtasitte/näitte

      Mitä olitte tekemässä? Millainen ympäristö oli? Löydetään toisemme...
      Ikävä
      139
      2137

    3. Olet kyllä vaarallisen himokas

      Luova, kaunis, määrätietoinen, pervo, mielenkiintoinen, kovanaama, naisellinen ja erikoinen.
      Ikävä
      111
      2116

    4. Mikä on hän on ammatiltaan?

      Vai tiedätkö mitä kaivattusi tekee työkseen?
      Ikävä
      92
      1915

    5. 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 tunnet
      Ikävä
      27
      1633

    6. Mitä ajattelit silloin kun

      Löysit hänet?
      Ikävä
      84
      1630

    7. Miksi homous puhuttaa konservatiiveja vuodesta toiseen?

      Kysymykseen on vastattukin Kansanlähetyksen osalta: "Miksi sukupuoleen ja seksuaalisuuteen liittyvät asiat ovat konserv
      Luterilaisuus
      285
      1144

    8. Syksyinen aamuketju suden

      Hyvää huomenta ja kaunista syyspäivää. 🌞🍁🍂☕
      Ikävä
      227
      1140

    9. Uskotko että kohdataan vielä?

      Kysymys otsikossa, aloitukseen ei muuta lisättävää.
      Ikävä
      72
      1138

    10. Oletko tutustunut muihin

      Samalla tavalla kuin häneen?
      Ikävä
      74
      968
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt