Hierarkia siirtymä-funktiolla

Puuaivo2

Minulla on Excel- tietokantoja, jossa on A-sarakkeessa tasoja ilmaisevat luvut 1-6, ja niihin liittyvät tiedot B-sarakkeessa.

Tarkoitus olisi saada aikaan hierarkiapuu, jossa 1. tason tiedot jäisivät B-sarakkeeseen, mutta seuraavat tasot aina yhden sarakkeen oikealle siten että 6. taso tulisi sarakkeeseen G.

Tein ensialkuun painikkeita, joissa oli koodi tyyliin:

Private Sub CommandButton1_Click()
Selection.Cut
ActiveCell.offset(0, 1).Select
ActiveSheet.Paste
End Sub

Painikkeiden käyttö osoittautui kuitenkin työlääksi tietokannan koon ollessa suuri. Suodatetut rivit kun piti valita yksitellen.

Yritin tehdä makroa, mutta taitoni eivät riittäneet.
Siksi käännyn gurujen puoleen, jos vaikka saisin pienen vihjeen homman ratkaisemiseksi.

13

309

    Vastaukset

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • karvalaggi

      Jos tämä on vain kertaluonteinen tapahtuma, tekisin minä näin. Esimerkissäni minulla on soluissa C1:H1 tasoluvut 1-6 (otsikot) ja tiedosto alkaa 2 riviltä. Kaavat:
      C2=JOS(A2=1;B2;"")
      D2=JOS(A2=2;B2;"")
      E2=JOS(A2=3;B2;"")
      F2=JOS(A2=4;B2;"")
      G2=JOS(A2=5;B2;"")
      H2=JOS(A2=6;B2;"")
      Valitse hiirellä solut C2:H2. Tuplaklikkaa solun H2 oikeassa alakulmassa olevaa "pallukkaa". Kaavat kopioituvat alaspäin niin pitkälle kuin A/B sarakkeissa on tietoja.
      Kopioidut solut jäävät "valituiksi". Suorita "Kopioi". Valitse solu C2 ja liitä määräten (vain arvot). Poista sarake B. Nyt sinulla on jaoteltu tiedot hierarkisesti sarakkeisiin B:G

      • Puuaivo2

        Kiitos. Tuokaltaisen virityksen olin jo tehnyt. Taulukoita on useita, ja niitä päivitetään jatkuvasti. Tarkoitus olisi saada käyttöön makrolla toimiva yleisemmässä käytössä oleva ratkaisu.


    • ORCL

      moduuliin:

      Sub MuokkaaHierarkiapuu()

      Dim Taso As Variant
      Dim ViimeinenRivi As Integer
      Dim i As Integer

      ViimeinenRivi = Cells(Rows.Count, 1).End(xlUp).Row

      For i = 1 To ViimeinenRivi

      Taso = Cells(i, 1).Value

      On Error Resume Next

      Select Case Taso

      Case 2
      Cells(i, 3).Value = Cells(i, 2).Value
      Cells(i, 2).ClearContents

      Case 3
      Cells(i, 4).Value = Cells(i, 2).Value
      Cells(i, 2).ClearContents

      Case 4
      Cells(i, 5).Value = Cells(i, 2).Value
      Cells(i, 2).ClearContents

      Case 5
      Cells(i, 6).Value = Cells(i, 2).Value
      Cells(i, 2).ClearContents

      Case 6
      Cells(i, 7).Value = Cells(i, 2).Value
      Cells(i, 2).ClearContents

      End Select

      Next i

      End Sub

      • Puuaivo2

        Kiitos. Tämä toimi hyvin. Sitä on helppo muokata myös laajentuneeseen taulukkoon sopivaksi.


    • moduuliin...

      Sub Siirrä()
      Dim Alue As Range
      For i = 1 To 6
      Set Alue = Etsi(i)
      Alue.Offset(0, i 1) = Alue.Offset(0, 1)
      Next
      Columns("B:B").Delete
      End Sub

      Function Etsi(Hakuehto As Variant) As Range
      Dim solu As Range
      Dim EkaOsoite As String
      With Range("A:A")
      Set solu = .Find( _
      What:=Hakuehto, _
      LookIn:=xlValues, _
      LookAt:=xlWhole, _
      SearchOrder:=xlByRows, _
      SearchDirection:=xlNext, _
      MatchCase:=False, _
      SearchFormat:=False)
      If Not solu Is Nothing Then
      Set Etsi = solu
      EkaOsoite = solu.Address
      Do
      Set Etsi = Union(Etsi, solu)
      Set solu = .FindNext(solu)
      Loop While Not solu Is Nothing And solu.Address <> EkaOsoite
      End If
      End With
      End Function

      Keep EXCELing
      @Kunde

      • Puuaivo2

        Kiitos. Kunden koodi on kunnianhimoisen näköistä, mutta en saanut sitä toimimaan. Makron suorituksessa tuli seuraavanlainen virheilmoitus:

        Microsoft Visual Basic for Applications
        Run-time error '91':
        Object variable or With block variable not set


    • plockare

      Minun versiossa valitaan ensin haluttu sarake tai sarakkeesta arvoalue, jossa on ne luvut kuinka etäälle kyseisestä luvusta oikealla olevan solun arvo siirretään. Esimerkiksi tässä tapauksessa valittaisiin sarake A ja ajettaisiin makro.

      Makrossa tarkastetaan ensin että valittuna on vain yhden sarakkeen tietoja. Sitten suodatetaan alueen soluista pelkästään positiiviset arvoltaan yli 1 olevat kokonaisluvut. Kun luku kelpaa, niin oikeanpuoleisen solun sisältöä siirretään luvun verran valintasarakkeesta oikealle päin.

      Pastebin-linkki jos s24 rikkoo tuon koodin, vaikkei tietysti sisennyksillä ole VBA:ssa mitään merkitystä: http://pastebin.com/m09YQ5WK

      Sub siirra()
      If Selection.Columns.Count() = 1 Then
      For Each cell In Selection
      If Len(cell.Value) > 0 Then
      If IsNumeric(cell.Value) = True Then
      If Int(cell.Value) = cell.Value And cell.Value > 1 Then
      cell.Offset(0, 1).Cut cell.Offset(0, cell.Value)
      End If
      End If
      End If
      Next
      End If
      End Sub

      • jos valitaan sarake reilut miljoona luuppia tekee, vaikka tarvitsisi esim. 30 riviä käydä läpi ;-)


      • Tämmöinen

        Jos välilyönnin korvaa sidotulla välilyönnillä, se muuttuu S24:ssä tavalliseksi välilyönniksi joka säilyy. Sidottu välilyönti ( Alt 0160) on suomalaisen standardin (SFS 5966) näppäimistössä Alt välilyönti.


      • Puuaivo2

        Kiitos. Tämä oli sellainen, että makro piti ajaa joka riviltä erikseen. Ei paljoa eroa omaan nappulaviritykseen.


      • plockare
        Puuaivo2 kirjoitti:

        Kiitos. Tämä oli sellainen, että makro piti ajaa joka riviltä erikseen. Ei paljoa eroa omaan nappulaviritykseen.

        Valitsitko varmasti kaikki lukuarvot sisältävän alueen (tai koko sarakkeen) ennen makron ajamista? Tuo käy siis koko valitun alueen läpi. Jos vain yksi solu on valittuna, niin silloin temput tehdään vain sen solun riville.


      • Puuaivo2

        Ok. Koko alueen valinta tosiaan auttoi. Siihen pitää vielä lisätä alueen valintaa varten koodia.


      • plockare
        Puuaivo2 kirjoitti:

        Ok. Koko alueen valinta tosiaan auttoi. Siihen pitää vielä lisätä alueen valintaa varten koodia.

        Joo siihen voi laittaa ensimmäiseksi riviksi vaikka Columns("A:A").Select tai Range("A1:A20").Select, jos alue on aina samassa kohtaa.


    Ketjusta on poistettu 0 sääntöjenvastaista viestiä.

    Luetuimmat keskustelut

    1. Useita puukotettu Tampereella

      Mikäs homma tämä nyt taas on? "Useaa henkilöä on puukotettu Tampereen keskustassa kauppakeskus Ratinan lähistöllä." ht
      Tampere
      169
      3319
    2. Asiakas iski kaupassa varastelua tehneen kanveesiin.

      https://www.iltalehti.fi/kotimaa/a/33a85463-e4d5-45ed-8014-db51fe8079ec Oikein. Näin sitä pitää. Kyllä kaupoissa valtava
      Maailman menoa
      373
      2141
    3. Kuka rääkkää eläimiä Puolangalla?

      Poliisi ampui toistakymmentä nälkiintynyttä eläintä Puolangalla Tilalta oli ollut karkuteillä lähes viisikymmentä nälkii
      Puolanka
      48
      2048
    4. Leipivaaran päällä on kuoleman hiljaista.

      Suru vai suuri helpotus...
      Puolanka
      41
      1951
    5. Meneeköhän sulla

      oikeasti pinnan alla yhtä huonosti kuin mulla? Tai yhtä huonosti mutta jollain eri tyylillä? Ei olisi pitänyt jättää sua
      Ikävä
      32
      1471
    6. Jos ei tiedä mitä toisesta haluaa

      Älä missään nimessä anna mitään merkkejä kiinnostuksesta. Ole haluamatta mitään. Täytyy ajatella toistakin. Ei kukaan em
      Ikävä
      93
      1241
    7. Määpä tiijän että rakastat

      Minua nimittäin. Samoin hei! Olet mun vastakappaleeni.
      Ikävä
      54
      1203
    8. Muutama kysymys ja huomio hindulaisesta kulttuurista.

      Vedakirjoituksia pidetään historiallisina teksteinä, ei siis "julistuksena" kuten esimerkiksi Raamattua, vaan kuten koul
      Hindulaisuus
      385
      1075
    9. Jumala puhui minulle

      Hän kertoi sinusta asioita, joiden takia jaksan, uskon ja luotan. Hän kuvaili sinua minulle ja pakahduin onnesta kuulles
      Ikävä
      114
      1003
    10. Koska näit kaivattusi viimeksi

      Milloin tapasit rakkaasi? Ja etenikö suhde yhtään?
      Ikävä
      45
      864
    Aihe