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

281

Ää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. IS: Väitöstutkimus - Pyöräilybuumi oli pelkkä kupla!

      Pyöräilybuumista paljastui karu totuus Väitöstutkimuksen mukaan suuri suomalainen pyöräilyrenessanssi olikin vain pelkk
      Maailman menoa
      20
      1414

    2. Turussa Varissuolla bussikuski ajoi lapsen yli lapsi kuoli

      Poliisi " Epäilee " kuskia törkeästä liikenneturvallisuuden vaarantamisesta ja törkeästä kuolemantuottamuksesta.
      Maailman menoa
      216
      1381

    3. Milloin bikineistä

      Tuli juhla tai esiintymis asu? Pikkasen harkintaa vois käyttää. Bikinit kuuluvat uimarannalle. No, mitä maailman tähdet
      Maailman menoa
      145
      1189

    4. Mene perheinesi arkkiin - kasteelle !

      Juutalaiset oli hyvin lapsirakkaita, mitään ehkäisyä ei käytetty. Perheissä oli paljon lapsia. Viiden koko perheen kast
      Kaste
      470
      1017

    5. Mitä kirjainta haluaisit rakastella?

      Ehdottomasti?
      Ikävä
      136
      978

    6. Olimmeko molemmat

      ujoja ja hankalia, vai minä vain? Mietin, oliko se silloin epävarmuutta vai kiinnostuksen puutetta.
      Ikävä
      73
      923

    7. Johanna Tukiainen ei suostu muuttamaan pois vuokra-asunnosta!

      Seiska kertoi tänään, että Johanna Tukiainen ei ole suostunut poistumaan Helsingin Munkkisaarenkadun vuokra-asunnostaan.
      Kotimaiset julkkisjuorut
      66
      867

    8. Mun on ikävä sua J ,

      Mun on ikävä sua J, haluaisin tutustua paremmin (vaikka tämä aivan älytöntä onkin). Voitaisiinko nähdä ja jutella ihan
      Ikävä
      47
      842

    9. Kehtaisitko kulkea mun kans yleisillä paikoilla

      vaikka käsi kädessä?
      Ikävä
      68
      804

    10. Apostolit kastoivat eri tavalla kuin kirkko

      Raamatussa on kaksi ristiriitaista kastekaavaa. Toinen ei voi olla oikea. Kumpi on alkuperäinen? "Menkää siis ja tehkää
      Kaste
      400
      794
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt