Instrucción adicional a macro ya creada

Para Dante Amor

Me ayudaste con la siguiente macro:

Sub modificar()
'Por.Dante Amor
    Set h2 = Sheets("BASE")
    Set h3 = Sheets("MODIFICAR")
    '
    If h3.[D10] = "" Then
        MsgBox "Número de Identificación VACIO." & vbCrLf & "" & vbCrLf & "Por favor escriba el número de Identificación en el espacio correspondiente.", vbExclamation
        [D10].Select
        Exit Sub
    End If
    '
    Set b = h2.Columns("C").Find(h3.[D10], lookat:=xlWhole)
    If Not b Is Nothing Then
        h2.Cells(b.Row, "C") = h3.[D12]
        h2.Cells(b.Row, "D") = h3.[D13]
        h2.Cells(b.Row, "E") = h3.[D14]
        h2.Cells(b.Row, "G") = h3.[D15]
        h2.Cells(b.Row, "H") = h3.[D16]
        h2.Cells(b.Row, "I") = h3.[D17]
        h2.Cells(b.Row, "J") = h3.[D18]
        h2.Cells(b.Row, "M") = h3.[D19]
        h2.Cells(b.Row, "Y") = h3.[F8]
        h2.Cells(b.Row, "T") = h3.[G17]
------- AQUI QUIERO LA INSTRUCCION QUE NECESITO ----------
    Else
        MsgBox "El número de Identificación no existe en la BASE DE DATOS." & vbCrLf & "" & vbCrLf & "Por favor verifique con el PACIENTE el número de Identificación e Intentelo de nuevo.", vbExclamation
        [D10].Select
    End If
    MsgBox "Se han ACTUALIZADO los datos del paciente EXITOSAMENTE." & vbCrLf & "" & vbCrLf & "Gracias por Mantener actualizada nuestra BASE DE DATOS." & vbCrLf & "" & vbCrLf & "Hasta Pronto.", vbInformation
    Range("D12:D19").Select
    Range("D19"). Activate
    Selection. ClearContents
    Range("D10").Select
    Selection. ClearContents
    ActiveWorkbook. Save
End Sub

Es que en la columna "T" de esa fila, tengo unas palabras separadas por el símbolo de "@" ejemplo: 

El hecho es que cuando hay dos "@@" seguidas es por que debe haber una columna vacía.

Ejemplo:

Esto es lo que deseo después de colocar la frase divididas con arrobas en la columna "T" y que empiece a dividir las palabras a partir de la siguiente columna es decir la columna "U"

1 Respuesta

Respuesta
1

H o l a:

Veo en tu imagen este ejemplo:

gloria@@sanchez@mendoza

Cómo quieres el resultado, qué quieres en la columna T, ¿qué quieres en la columna U y si hay más veces la doble @, qué es lo que quisieras?

S a l u d o s

De hecho, lo que se pone en la columna T, viene de lo que está en la celda G17, ¿entonces puedes poner un ejemplo completo de lo que tienes en la celda G17 y cómo quieres que se acomoden los datos?

Te voy a aclarar tus inquietudes.

En la columna G17 simplemente hay unas palabras que en lugar de "barra esopaciadora" se unen a través de un símbolo de arroba.

Ejemplo:

carro@perro@gato@ave (G17 que se copia a la columna T)

Eso ya lo tengo. Lo que quiero es que en la columna "U" ponga la primera palabra, en la columna "V" ponga la segunda palabra, en la columna "W" la tercera y en la columna "X" la cuarta palabra.

Pero no siempre van a haber 4 palabras, pueden haber casos de 3 palabras o 2 palabras.

carro@@perro@gato

En este caso, si te das cuentas hay una doble arroba por que debe haber una columna vacía, entonces en la columna "U" en este ejemplo se pone la palabra "carro" en la columna "V" se deja vacía (Como no hay nada entre @ y @ entonces la columna debe quedar vacía) en la columna "W" perro y en la columna "X" gato.

carro@perro@pato

En este caso, en la columna "U" en este ejemplo se pone la palabra "carro" en la columna "V" se pone "perro", en la columna "W" la palabra "pato" y en la "X" se deja vacia.

carro@@perro

Columna "U" : Carro

Columna "V":  vacia

Columna "W" : Perro

Columna "X" : Vacia

Espero me halla hecho entender

H o l a

Te anexo la macro actualizada

Sub modificar()
'Por.Dante Amor
    Set h2 = Sheets("BASE")
    Set h3 = Sheets("MODIFICAR")
    Application.DisplayAlerts = False
    '
    If h3.[D10] = "" Then
        MsgBox "Número de Identificación VACIO." & vbCrLf & "" & vbCrLf & "Por favor escriba el número de Identificación en el espacio correspondiente.", vbExclamation
        [D10].Select
        Exit Sub
    End If
    '
    Set b = h2.Columns("C").Find(h3.[D10], lookat:=xlWhole)
    If Not b Is Nothing Then
        h2.Cells(b.Row, "C") = h3.[D12]
        h2.Cells(b.Row, "D") = h3.[D13]
        h2.Cells(b.Row, "E") = h3.[D14]
        h2.Cells(b.Row, "G") = h3.[D15]
        h2.Cells(b.Row, "H") = h3.[D16]
        h2.Cells(b.Row, "I") = h3.[D17]
        h2.Cells(b.Row, "J") = h3.[D18]
        h2.Cells(b.Row, "M") = h3.[D19]
        h2.Cells(b.Row, "Y") = h3.[F8]
        h2.Cells(b.Row, "T") = h3.[G17]
        h2.Cells(b.Row, "T").TextToColumns Destination:=h2.Cells(b.Row, "U"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, _
        OtherChar:="@", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True
    Else
        MsgBox "El número de Identificación no existe en la BASE DE DATOS." & vbCrLf & "" & vbCrLf & "Por favor verifique con el PACIENTE el número de Identificación e Intentelo de nuevo.", vbExclamation
        [D10].Select
    End If
    MsgBox "Se han ACTUALIZADO los datos del paciente EXITOSAMENTE." & vbCrLf & "" & vbCrLf & "Gracias por Mantener actualizada nuestra BASE DE DATOS." & vbCrLf & "" & vbCrLf & "Hasta Pronto.", vbInformation
    Range("D12:D19").Select
    Range("D19"). Activate
    Selection. ClearContents
    Range("D10").Select
    Selection. ClearContents
    ActiveWorkbook. Save
End Sub

Excelente Dante, la estuve probando y en la mayoria de casos funcionó solo que si el que esta digitando los nombres, comete un error y pone una "@" de más, todo saldria mal por que mi idea es que no pueden haber mas de 3 (tres) simbolos de "@"

Ejemplo:

carro@perro = OK

carro@perro@gato = OK

carro@perro@gato@gusano = OK

pero

pedro@juliana@sergio@laura@jose = ERROR

Que instrucción se le podría poner a esa macro para que antes de hacer todo lo que hace, evaluara en "G17" si esa cadena de caracteres tiene mas de 3 (tres) arrobas y si tiene mas de 3 "@" entonces sacara un mensaje de aviso indicando que "Favor corregir la celda G17 debido a que posee mas "@" de las permitidas

Te anexo la macro actualizada:

Sub modificar()
'Por.Dante Amor
    Set h2 = Sheets("BASE")
    Set h3 = Sheets("MODIFICAR")
    Application.DisplayAlerts = False
    '
    If h3.[D10] = "" Then
        MsgBox "Número de Identificación VACIO." & vbCrLf & "" & vbCrLf & "Por favor escriba el número de Identificación en el espacio correspondiente.", vbExclamation
        [D10].Select
        Exit Sub
    End If
    '
    For j = 1 To Len(h3.[G17])
        If Mid(h3.[G17], j, 1) = "@" Then
            con = con + 1
        End If
    Next
    If con > 3 Then
        MsgBox "Favor corregir la celda G17 debido ya que posee mas ''@'' de las permitidas"
        Exit Sub
    End If
    '
    Set b = h2.Columns("C").Find(h3.[D10], lookat:=xlWhole)
    If Not b Is Nothing Then
        h2.Cells(b.Row, "C") = h3.[D12]
        h2.Cells(b.Row, "D") = h3.[D13]
        h2.Cells(b.Row, "E") = h3.[D14]
        h2.Cells(b.Row, "G") = h3.[D15]
        h2.Cells(b.Row, "H") = h3.[D16]
        h2.Cells(b.Row, "I") = h3.[D17]
        h2.Cells(b.Row, "J") = h3.[D18]
        h2.Cells(b.Row, "M") = h3.[D19]
        h2.Cells(b.Row, "Y") = h3.[F8]
        h2.Cells(b.Row, "T") = h3.[G17]
        h2.Cells(b.Row, "T").TextToColumns Destination:=h2.Cells(b.Row, "U"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, _
        OtherChar:="@", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True
    Else
        MsgBox "El número de Identificación no existe en la BASE DE DATOS." & vbCrLf & "" & vbCrLf & "Por favor verifique con el PACIENTE el número de Identificación e Intentelo de nuevo.", vbExclamation
        [D10].Select
    End If
    MsgBox "Se han ACTUALIZADO los datos del paciente EXITOSAMENTE." & vbCrLf & "" & vbCrLf & "Gracias por Mantener actualizada nuestra BASE DE DATOS." & vbCrLf & "" & vbCrLf & "Hasta Pronto.", vbInformation
    Range("D12:D19").Select
    Range("D19"). Activate
    Selection. ClearContents
    Range("D10").Select
    Selection. ClearContents
    ActiveWorkbook. Save
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas