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

261

Ää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. 24h Kirppis

      Olen muuttamassa paikkakunnalle ja mietin olisiko tälläiselle liikkeelle tarvetta alueella?
      Jämsä
      14
      3779

    2. Kerotakaa joensuun kontiolahden paiholan laitoksesta jotain

      Mun kaveri joutuu paiholan laitokseen nyt lähi aikoina niin voisko ihmiset kertoa minkälaista siellä on tarinoita jne ja
      Joensuu
      28
      3078

    3. Suomessa eletään liian pitkään

      "Ihmisten on kuoltava" Asiantuntija varoittaa: Suomi ei ole valmis siihen, että niin moni elää pitkään: ”Kaiken täytyy
      Maailman menoa
      280
      2905

    4. Deodoranttiteollisuus

      Annan ilmaisen vinkin. Kyseinen teollisuus voisi alkaa valmistaa kuolleen ruumiin hajua. Olisi varma hittituote, ainakin
      Jämsä
      7
      1971

    5. Trump syyttää Bideniä ja Obamaa lentoonnettomuudesta!

      Ukko on ihan seonnut.
      Maailman menoa
      233
      1610

    6. Voitaisko olla kavereita?

      Haluaisin aloittaa puhtaalta pöydältä sinun kanssasi, tabula rasa. Minä lopetan sinun perääsi haikailun, ja sitten sinäk
      Tunteet
      6
      1390

    7. Näyttääkö kaivattusi

      Miten hyvältä ❤️
      Ikävä
      75
      1281

    8. Martinan mies on Suomessa.

      Siellä se on Martinan instassa ja täällä on jo ero tullut. Voi että kun huvittaa...
      Kotimaiset julkkisjuorut
      203
      1245

    9. Rukoilimme Länsimuurilla 2000 vuoden jälkeen, Jumalamme oli antanut meille kaiken takaisin

      Western Wall, In our Hands. 55th Para. https://www.youtube.com/watch?v=u4BJAppyCSo https://en.wikipedia.org/wiki/55th_
      Ateismi
      4
      1071

    10. Maistaisitko sinä näitä valmisruokia?

      Terhi Kinnari ja Kinnarin tila voitti Suomalainen menestysresepti -kisan. Makuja Kinnarin tilan kaurapohjaisissa aterioi
      Einekset
      32
      1065
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt