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
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
Vastaukset 7
Vanhimmat
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
pelittää. Suuret kiitokset!
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.
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ä.
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
No nyt toimii! Kiitos nopeasta toiminnasta!