Pitäisi saada b-sarakkeessa oleva teksti sarakkeisiin, niin että muotoilut säilyisivät. Erottimena toimii välilyönti.
"Teksti sarakkeisiin" ja "poimi.teksti" poistaa muotoilut...
Kiitos avusta!
"Teksti sarakkeisiin" ja "poimi.teksti" poistaa muotoilut...
Kiitos avusta!
Vastaukset 5
Vanhimmat
Kopioi ensin B-sarakkeen muotoilut niihin sarakkeisiin joihin teksti "leviää".
Joko Kopioi -> liitä määräten -> muotoilut ja OK, tai muotoilusiveltimellä.
Sitten vain teksti sarakkeisiin..
moduuliin...
Sub TekstiSiirto()
Dim vika As Integer
Dim a As Variant
On Error Resume Next
Application.ScreenUpdating = False
vika = Range("B65536").End(xlUp).Row
For Each solu In Range("B1:B" & vika)
a = Split(solu, " ") ' erottimena välilyönti
For i = 1 To UBound(a) 1
solu.Copy
solu.Offset(0, i 1).PasteSpecial Paste:=xlPasteFormats
solu.Offset(0, i 1) = a(i - 1)
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
toiminut kummallakaan tavalla niin kuin piti...
B-sarakkeessa oleva teksti on lyhenteitä (1-4 kirjainta ja lyhenteitä on 21 kpl), jotka on muotoiltu eri värein. Eli samassa "rimpsussa" saattaa olla useita värejä. Värien järjestys ei ole sama joka rivillä.
Nyt molemmat tavat muotoili tekstin ensimmäisen lyhenteen mukaan.
etpähän maininnut alkujaan, että solussa useampi muotoilu...
no nyt koodi tekee haluamasi
Sub TekstiSiirto()
Dim vika As Integer
Dim a As Variant
Dim Alku As Integer
Dim Pituus As Integer
On Error Resume Next
Application.ScreenUpdating = False
vika = Range("B65536").End(xlUp).Row
For Each solu In Range("B1:B" & vika)
a = Split(solu, " ") ' erottimena välilyönti
Alku = 1
For i = 1 To UBound(a) 1
Pituus = Len(a(i - 1))
väri = solu.Characters(Start:=Alku, Length:=Pituus).Font.ColorIndex
solu.Offset(0, i) = a(i - 1)
solu.Offset(0, i).Characters(Start:=1).Font.ColorIndex = väri
Alku = Alku Pituus 1
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
huono alustus!
Nyt tekee mitä pitääkin. Suuret kiitokset!