Kopiointia

pom

Pitäisi saada Taul1:een namiska, joka kopioisi Taul2:een, mikäli D-sarakkeessa on luku, samalla rivillä olevat B- ja C-solut. B- ja C-soluja pitäisi kopsata niin monta kuin D-sarakkeen luku näyttää.
Solujen muotoilujen tulisi säilyä. Samassa solussa on muotoiluna lihavointi, kursivointi ja osa solun sisällöstä on ilman muotoilua.
Esim. Taul1
B2=Matti, C3=Meikäläinen, D3= 2
B15=Maija, C15=Mehiläinen, D15= 3

Taul2(A1:B5)
Matti Meikäläinen
Matti Meikäläinen
Maija Mehiläinen
Maija Mehiläinen
Maija Mehiläinen

7

359

Äänestä

    Vastaukset

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • kunde

      moduuliin ja liität makron nappiin

      Sub KopioiJaSiirrä()
      Dim vika As Integer
      Dim vika2 As Integer
      Dim kopio As Range
      Dim i As Integer
      On Error Resume Next
      Taul1.Activate
      Sheets("Taul2").Range("A1:B" & Sheets("Taul2").Range("A65536").End(xlUp).Row) = ""
      vika = Sheets("Taul1").Range("D65536").End(xlUp).Row
      For Each solu In Sheets("Taul1").Range("D1:D" & vika)
      If solu "" And IsNumeric(solu) Then
      Set kopio = solu.Offset(0, -2).Resize(1, 2)
      For i = 1 To solu.Value
      vika2 = Sheets("Taul2").Range("A1").End(xlDown).Row
      If vika2 = 0 Then
      vika2 = 1
      Else
      vika2 = vika2 1
      End If
      kopio.Copy Destination:=Sheets("Taul2").Range("A" & vika2)
      Next i
      End If
      Next
      End Sub

      • pom

        pelittää. Suuret kiitokset!

    • pom2

      Minkäs takia tämä ei toimi enää rivin 32767 jälkeen? Tarvis ois saada 140 000 riviä pelittämään. Käytössä Excel 2007.

      • kunde

        niin se kehitys kulkee eteenpäin.
        aikanaan Excelissä oli max 65536 riviä.
        versiossa 2007 rivimäärä kasvoi max 1,048,576 riviin.

        koodissani olen käyttänyt Integer muuttujaa max 32767
        nyt se kuitenkin pitäisi muuttaa Long tyyppiksi max 2147483647

        Sub KopioiJaSiirrä()
        Dim vika As Long
        Dim vika2 As Long
        Dim kopio As Range
        Dim i As Long
        On Error Resume Next
        Taul1.Activate
        Sheets("Taul2").Range("A1:B" & Sheets("Taul2").Range("A65536").End(xlUp).Row) = ""
        vika = Sheets("Taul1").Range("D65536").End(xlUp).Row
        For Each solu In Sheets("Taul1").Range("D1:D" & vika)
        If solu "" And IsNumeric(solu) Then
        Set kopio = solu.Offset(0, -2).Resize(1, 2)
        For i = 1 To solu.Value
        vika2 = Sheets("Taul2").Range("A1").End(xlDown).Row
        If vika2 = 0 Then
        vika2 = 1
        Else
        vika2 = vika2 1
        End If
        kopio.Copy Destination:=Sheets("Taul2").Range("A" & vika2)
        Next i
        End If
        Next
        End Sub

        Keep EXCELing
        @Kunde

      • pom2
        kunde kirjoitti:

        niin se kehitys kulkee eteenpäin.
        aikanaan Excelissä oli max 65536 riviä.
        versiossa 2007 rivimäärä kasvoi max 1,048,576 riviin.

        koodissani olen käyttänyt Integer muuttujaa max 32767
        nyt se kuitenkin pitäisi muuttaa Long tyyppiksi max 2147483647

        Sub KopioiJaSiirrä()
        Dim vika As Long
        Dim vika2 As Long
        Dim kopio As Range
        Dim i As Long
        On Error Resume Next
        Taul1.Activate
        Sheets("Taul2").Range("A1:B" & Sheets("Taul2").Range("A65536").End(xlUp).Row) = ""
        vika = Sheets("Taul1").Range("D65536").End(xlUp).Row
        For Each solu In Sheets("Taul1").Range("D1:D" & vika)
        If solu "" And IsNumeric(solu) Then
        Set kopio = solu.Offset(0, -2).Resize(1, 2)
        For i = 1 To solu.Value
        vika2 = Sheets("Taul2").Range("A1").End(xlDown).Row
        If vika2 = 0 Then
        vika2 = 1
        Else
        vika2 = vika2 1
        End If
        kopio.Copy Destination:=Sheets("Taul2").Range("A" & vika2)
        Next i
        End If
        Next
        End Sub

        Keep EXCELing
        @Kunde

        Vaan eipä näytä toimivan ollenkaan Long tyypillä.

      • kunde
        pom2 kirjoitti:

        Vaan eipä näytä toimivan ollenkaan Long tyypillä.

        korjasin noi soluosoitteet isommiksi
        ainakin mulla pelaa v 2010

        Sub KopioiJaSiirrä()
        Dim vika As Long
        Dim vika2 As Long
        Dim kopio As Range
        Dim i As Long
        On Error Resume Next
        Taul1.Activate
        Sheets("Taul2").Range("A1:B" & Sheets("Taul2").Range("A1045876").End(xlUp).Row) = ""
        vika = Sheets("Taul1").Range("D1045876").End(xlUp).Row
        For Each solu In Sheets("Taul1").Range("D1:D" & vika)
        If solu "" And IsNumeric(solu) Then
        Set kopio = solu.Offset(0, -2).Resize(1, 2)
        For i = 1 To solu.Value
        vika2 = Sheets("Taul2").Range("A1045876").End(xlUp).Row
        If vika2 = 0 Then
        vika2 = 1
        Else
        vika2 = vika2 1
        End If
        kopio.Copy Destination:=Sheets("Taul2").Range("A" & vika2)
        Next i
        End If
        Next
        End Sub

    • pom2

      No nyt toimii! Kiitos nopeasta toiminnasta!

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

    Takaisin ylös

    Luetuimmat keskustelut

    1. Oletko tyytyväinen viime tapaamiseemme?

      Vai toivoitko sen menevän toisella tavalla? Miten?
      Ikävä
      67
      2801

    2. Nyt se sit loppuu

      Et ei enää nähdä ja yhteyttä pidetä.
      Ikävä
      46
      2554

    3. Kuoleman pelko katosi

      Olen pelännyt koko elämän ajan kuolemaa mutta yhtäkkiä kun hindut paljastivat totuuksia uskonnoista noin aloin yhtäkkiä
      Hindulaisuus
      431
      2217

    4. Viikonloppu terveiset kaivatulle

      tähän alas ⬇️⬇️⬇️
      Ikävä
      79
      2128

    5. Jos sitä keittelis teetä

      Ja miettis mitä mies siellä jossain touhuilee... ☕️
      Ikävä
      95
      1956

    6. Myötähäpeä kun näkee sut,

      tekisit jotain ittelles. Ihan hyvällä tämä!
      Ikävä
      32
      1692

    7. Huomenta ........

      Huomenta 💗 Tiedän, että tuntuisit hyvälle.
      Ikävä
      12
      1526

    8. Kuhmolainen on selvästi kepun lehti

      Kuhmolaise etukannessa oli Kuva kun Jaskalle annettiin karhu patsas.mutta kukmolaislehti oli niin kepulainen että Jaskan
      Kuhmo
      17
      1477

    9. Mitä nämä palautteet palstalla ovat?

      Joku uusi toimintatapa rohkaista kirjoittajia vai mistä on kyse?
      Ikävä
      26
      1283

    10. Ei mun tunteet

      ole mihinkään kadonnut. Enkä mä sua inhoa tai ole kyllästynyt. Mä ymmärsin, ettet ole kiinnostunut minusta, ainakaan sil
      Ikävä
      18
      1165
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt