Mejora en Macro Actual para dividir el contenido de una celda en 4 celdas

Por medio de la presente quisieras que me ayudaras con lo siguiente, tengo la actual macro que te envío a continuación:

Sub ALMACENAR()
'Por.Dante Amor
    Set h2 = Sheets("CLIENTES")
    Set h3 = Sheets("FORMULARIO")
    '
    If h3.[E7] = "" Then
        MsgBox "Ingrese el ID en la celda E7", vbExclamation
        [E7].Select
        Exit Sub
    End If
    '
    Set b = h2.Columns("C").Find(h3.[E7], lookat:=xlWhole)
    If Not b Is Nothing Then
        MsgBox "El Paciente ya existe en la Base de Datos.", vbExclamation
    Else
        h3.Range("E5:E16").Copy
        u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
        h2.Cells(u, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        h2.Range("F2").Copy h2.Cells(u, "F")
        h3.Range("E6:E9").ClearContents
        h3.Range("E11:E16").Cells.ClearContents
        ActiveWorkbook.Save
        MsgBox "Paciente Registrado", vbInformation
    End If
End Sub

Como tu te puedes dar cuenta tu me ayudaste a diseñarla (gracias) pero quisiera realizarle una modificación que necesito:

Si tu te das cuenta el toma los datos de la hoja formulario desde E5 hasta E16 y los copia tal cual, en la hoja Clientes en la próxima fila vacía desde la columna A en adelante. Y hace unas operaciones adicionales.

Ahora en lo que me gustaría que me ayudaras es en lo siguiente, resulta que la celda E8 de la hoja Formulario ya no solo contiene 1 sola palabra sino que puede contener 2 ó 3 ó 4 palabras como máximo.

En lo que quisiera que me ayudaras por el momento como para no dañar la macro que ya existe es que por ejemplo después de realizar la labor de trasladar los datos de la hoja Formulario a la hoja Clientes, la macro tomara el dato contenido en la celda C8 de la hoja formulario y me dividiera su contenido en 4 columnas de la hoja clientes comenzando desde la columna U luego la columna V luego la columna W y luego la columna X.

Te voy a dar ejemplos para que me comprendas mejor:

Ejemplo 1: Que en la celda C8 estuviera escrito lo siguiente "JUAN PEREZ"

Si te das cuenta, yo he definido con ese ejemplo que como la persona no tiene segundo nombre, lo que hago es dar un doble espacio entre JUAN y entre PEREZ, entonces la macro al ver eso lo que debería hacer es que en la columna U de la hoja clientes pondría JUAN y en la columna V la debe dejar vacía por que hay un doble espacio entre JUAN y PEREZ y en la columna W debe poner PEREZ y en la columna X la debe dejar vacía por que tampoco tienen segundo apellido.

Ejemplo 2: En la celda C8 estuviera escrito lo siguiente "JUAN PEREZ MORENO"

U: JUAN V: Vacio W: PEREZ X: MORENO

Ejemplo 3: Celda C8 con "JUAN ALBERTO PEREZ"

U: JUAN V: ALBERTO W:PEREZ X: Vacío

Ejemplo 4: Celda C8 con "JUAN ALBERTO PEREZ MORENO"

U: JUAN V: ALBERTO W: PEREZ X: MORENO

1 Respuesta

Respuesta
1

H o l a:

Te anexo la macro actualizada.

Sub ALMACENAR()
'Por.Dante Amor
    Set h2 = Sheets("CLIENTES")
    Set h3 = Sheets("FORMULARIO")
    '
    If h3.[E7] = "" Then
        MsgBox "Ingrese el ID en la celda E7", vbExclamation
        [E7].Select
        Exit Sub
    End If
    '
    Set b = h2.Columns("C").Find(h3.[E7], lookat:=xlWhole)
    If Not b Is Nothing Then
        MsgBox "El Paciente ya existe en la Base de Datos.", vbExclamation
    Else
        h3.Range("E5:E16").Copy
        u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
        h2.Cells(u, "A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        h2.Range("F2").Copy h2.Cells(u, "F")
        nombres = Split(h3.[E8], " ")
        col = Columns("U").Column
        If UBound(nombres) > 1 Then
            For i = LBound(nombres) To UBound(nombres)
                h2.Cells(u, col) = nombres(i)
                col = col + 1
            Next
        End If
        '
        h3.Range("E6:E9").ClearContents
        h3.Range("E11:E16").Cells.ClearContents
        ActiveWorkbook.Save
        MsgBox "Paciente Registrado", vbInformation
    End If
End Sub

' : )
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
' : )

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas