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

361

Ää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. Useita puukotettu Tampereella

      Mikäs homma tämä nyt taas on? "Useaa henkilöä on puukotettu Tampereen keskustassa kauppakeskus Ratinan lähistöllä." ht
      Tampere
      266
      4783

    2. Kuka rääkkää eläimiä Puolangalla?

      Poliisi ampui toistakymmentä nälkiintynyttä eläintä Puolangalla Tilalta oli ollut karkuteillä lähes viisikymmentä nälkii
      Puolanka
      80
      3227

    3. Laitetaas nyt kirjaimet tänne

      kuka kaipaa ja ketä ?
      Ikävä
      36
      2643

    4. Leipivaaran päällä on kuoleman hiljaista.

      Suru vai suuri helpotus...
      Puolanka
      47
      2523

    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ä
      45
      1797

    6. Koska näit kaivattusi viimeksi

      Milloin tapasit rakkaasi? Ja etenikö suhde yhtään?
      Ikävä
      97
      1590

    7. Lähetä terveisesi kaipaamallesi henkilölle

      Vauva-palstalta tuttua kaipaamista uudessa ympäristössä. Kaipuu jatkukoon 💘
      Ikävä
      94
      1368

    8. PS uusimman gallupin rakettimainen nousija

      https://yle.fi/a/74-20170641 Aivan ylivoimaisesti suurin kannatuksen nousu PS:lle. Nousu on alkanut ja jatkuu 2 vuoden
      Maailman menoa
      144
      1005

    9. Tekiskö nainen mieli tavata...

      Viikonloppuna ja...?
      Ikävä
      69
      988

    10. Laita vielä yksi viesti

      Saisin rohkeutta☺️ Naiselta
      Ikävä
      99
      938
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt