Reordenar textos en columnas en excel
Necesito reodenar ciertos textos de unas celdas a otra hoja. Asignandole color
Para dante amor
1 respuesta
Respuesta de Dante Amor
1
H o l a:
Envíame tu archivo con ejemplos reales de cómo quieres el resultado. Debes cambiar las imágenes por "X"
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “David Lezcano” y el título de esta pregunta.
Te anexo la macro actualizada:
Sub ReordenarTextos()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("Pregunta")
Set h2 = Sheets("Ordenado")
h2.UsedRange.Offset(1, 0).Clear
'
Set r = h1.Range("B:D")
Set b = r.Find("Pregunta", lookat:=xlPart)
j = 2
If Not b Is Nothing Then
ncell = b.Address
Do
'detalle
If h1.Cells(b.Row, "A").MergeCells Then
preg = h1.Cells(b.Row, "A").MergeArea.Cells(1, 1)
Else
preg = h1.Cells(b.Row, "A")
End If
'
n = j
h2.Cells(j, "A") = preg
h2.Cells(j, "B") = h1.Cells(b.Row, "E")
With h2.Range(h2.Cells(j, "A"), h2.Cells(j + 3, "A"))
.Merge
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
End With
With h2.Range(h2.Cells(j, "B"), h2.Cells(j + 3, "B"))
.Merge
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
End With
'
For i = b.Row To h1.Range("B" & Rows.Count).End(xlUp).Row
Select Case h1.Cells(i, "B")
Case "Nota"
If h1.Cells(i, "B").MergeCells Then
ini = h1.Cells(i, "B").MergeArea.Cells(1, 1).Row
fin = h1.Cells(i, "B").MergeArea.Rows.Count + i - 1
Else
ini = i
fin = i
End If
m = j
For k = ini To fin
If h1.Cells(k, "E") <> "" Then
With h2.Cells(m, "C")
.Value = h1.Cells(k, "E")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
End With
m = m + 1
End If
Next
Case ""
Case 1, 2, 3, 4
With h2.Cells(n, "D")
.Value = h1.Cells(i, "E")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = True
If UCase(h1.Cells(i, "D")) = "X" Then
.Font.Color = RGB(0, 176, 80)
.Font.Bold = True
End If
End With
n = n + 1
If h1.Cells(i, "B") = 4 Then Exit For
End Select
Next
If n > m Then j = n Else j = m
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Application.ScreenUpdating = True
h2.Select
MsgBox "Preguntas copiadas", vbInformation
End Sub‘
S a l u d o s . D a n t e A m o r. Recuerda valorar la respuesta. G r a c i a s
