Copy and paste rows with different fonts inside them.

Kirbito

New Member
Joined
May 6, 2024
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
Hello everyone!
I have an excel with this format:
Row 1: text
Row 2: text
Row 3: text
Row 4: Blanc
Row 5: text
Row 6: text
Row 7: Blanc
...

the following scrypt that I have lets me combine all the rows that are not separated by a blanc row inside a single row:
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Sub CombinarTextoEntreEspaciosEnBlanco()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim combinedText As String
Dim targetCell As Range
Dim firstLine As String

' Establecer la hoja de trabajo en la que se encuentra tu rango de datos
Set ws = ThisWorkbook.Sheets("NombreDeTuHoja")

' Establecer el rango que contiene los datos
Set rng = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)

' Inicializar la celda objetivo donde se combinará el texto
Set targetCell = ws.Range("Z1") ' Cambia "Z1" al rango de celda donde deseas que aparezca el resultado

' Inicializar el texto combinado y la primera línea
combinedText = ""
firstLine = ""

' Iterar a través de cada celda en el rango
For Each cell In rng
' Si la celda está vacía, pegar el texto combinado en la celda objetivo y reiniciar las variables
If cell.Value = "" Then
If Len(combinedText) > 0 Then
' Pegar el texto combinado en la celda objetivo
targetCell.Value = combinedText

' Hacer que la primera línea esté en negrita
targetCell.Characters(Start:=1, Length:=Len(firstLine)).Font.Bold = True

' Mover la celda objetivo a la siguiente fila
Set targetCell = targetCell.Offset(1, 0)

' Reiniciar las variables
combinedText = ""
firstLine = ""
End If
Else
' Si la celda no está vacía, agregar su valor al texto combinado
If combinedText = "" Then
' Si es la primera línea, guardarla para formatearla en negrita después
firstLine = cell.Value
Else
' Agregar salto de línea si no es la primera línea
combinedText = combinedText & vbCrLf
End If

' Agregar el valor de la celda al texto combinado
combinedText = combinedText & cell.Value
End If
Next cell

' Pegar el último texto combinado después del último espacio en blanco
If Len(combinedText) > 0 Then
targetCell.Value = combinedText

' Hacer que la primera línea esté en negrita
targetCell.Characters(Start:=1, Length:=Len(firstLine)).Font.Bold = True
End If
End Sub

(Pasted and working from Chatgpt)
The problem is that inside the same row there are words written in different fonts, and they result of the script appears as a single font.
Is there any way to fix that?
Thanks in advance for your time!

(And sorry for double posting)
 
Upvote 0

Forum statistics

Threads
1,216,106
Messages
6,128,863
Members
449,473
Latest member
soumyahalder4

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top