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
pom
5
827
Vastaukset
- paavali50
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- pom
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. pom kirjoitti:
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- pom
kunde kirjoitti:
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 Subhuono alustus!
Nyt tekee mitä pitääkin. Suuret kiitokset!
Ketjusta on poistettu 0 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
- 1251278
Ketä naista se poju tällä hetkellä vetää höplästä
Sillä kun pitää aina olla joku höplästä vedettävä kierroksessa283939- 43845
- 33631
Tappio Rydmanille
Ei pystynyt Wille saamaan tahtonsa läpi. https://www.hs.fi/politiikka/art-2000012093775.html144610- 38587
- 52551
Sometähti villisika-Seppo on kuollut
Suomussalmella lemmikkieläimeksi virallisesti hyväksytty villisika Seppo on kuollut. https://yle.fi/a/74-2023244528518Tiesitkös rakas
Mun taivas on pilvinen ja synkkä. Päivät värittömiä ja harmaita. Missä olet, aurinkoni? 💔44501- 106477