Separar una parte del texto de una celda en 3 celdas escogidas excel vba
La celda Tienen esta forma
.....; fruta1 / fruta2 / fruta3 ; .......
Siempre se separa por el / y en muchos casos no hay ; al inicio o al final o en ambos lados.
Necesito que extraía el contenido de la celda con el texto en 3 distintas ejemplo B5= fruta1, B15= fruta2, H12= fruta3 alguna idea amigo tu código realiza muy bien el trabajo pero me gustaría que las celdas a donde se vaya el resultado sea las que yo defina.
Alguna
¿En qué celda esta el texto original? En tu pregunta anterior, tenias los textos en la columna A uno debajo de otro. Y mi codigo hacia un bucle y separaba todos de una vez. Ahora no entiendo, ¿vas a validar solo uno a la vez? Los resultados siempre van a ir a B5, ¿B15 y H12? ¿Puedes mostrar una imagen de la hoja como debe quedar?
En la celda B2 sino que en el problema anterior definía los posibles casos que pueden habe, luego de eso estraiga las frutas en las celdas mencionadas
Vale, como no se como lo quieres ejecutar, te lo hice a modo de función, ya que siempre son 3 frutas, te hice 3 funciones.
En este video puedes ver como funcionan: video demo
Colocas la fórmula en las celdas que tu quieras, en este caso en B5, B15 y H12
Lo bueno de esta forma es que luego la puedes usar donde quieras, y el texto original también puede estar donde quieras, no solo en B2.
Estos son los 3 códigos, pega todo esto en un modulo:
Function Fruta1(Rng As Range) As String Application.ScreenUpdating = False If IsEmpty(Rng) Then Fruta1 = "": Exit Function Dim cCol As Byte Dim i As Byte Dim rCell As Range Dim TempStr() As String TempStr = Split(Rng.Value, "/") If InStr(TempStr(0), ";") > 0 Then TempStr(0) = Right(TempStr(0), Len(TempStr(0)) - InStr(TempStr(0), ";")) End If If InStr(TempStr(UBound(TempStr)), ";") > 0 Then TempStr(UBound(TempStr)) = Left(TempStr(UBound(TempStr)), InStr(TempStr(UBound(TempStr)), ";") - 1) End If If UBound(TempStr) >= 0 Then Fruta1 = Trim(TempStr(0)) Else Fruta1 = "" End If Application.ScreenUpdating = True End Function Function Fruta2(Rng As Range) As String Application.ScreenUpdating = False If IsEmpty(Rng) Then Fruta2 = "": Exit Function Dim cCol As Byte Dim i As Byte Dim rCell As Range Dim TempStr() As String TempStr = Split(Rng.Value, "/") If InStr(TempStr(0), ";") > 0 Then TempStr(0) = Right(TempStr(0), Len(TempStr(0)) - InStr(TempStr(0), ";")) End If If InStr(TempStr(UBound(TempStr)), ";") > 0 Then TempStr(UBound(TempStr)) = Left(TempStr(UBound(TempStr)), InStr(TempStr(UBound(TempStr)), ";") - 1) End If If UBound(TempStr) >= 1 Then Fruta2 = Trim(TempStr(1)) Else Fruta2 = "" End If Application.ScreenUpdating = True End Function Function Fruta3(Rng As Range) As String Application.ScreenUpdating = False If IsEmpty(Rng) Then Fruta3 = "": Exit Function Dim cCol As Byte Dim i As Byte Dim rCell As Range Dim TempStr() As String TempStr = Split(Rng.Value, "/") If InStr(TempStr(0), ";") > 0 Then TempStr(0) = Right(TempStr(0), Len(TempStr(0)) - InStr(TempStr(0), ";")) End If If InStr(TempStr(UBound(TempStr)), ";") > 0 Then TempStr(UBound(TempStr)) = Left(TempStr(UBound(TempStr)), InStr(TempStr(UBound(TempStr)), ";") - 1) End If If UBound(TempStr) >= 2 Then Fruta3 = Trim(TempStr(2)) Else Fruta3 = "" End If Application.ScreenUpdating = True End Function
Andy
¡Gracias! Usted cree que me podría brindar una ayuda o orientación con este caso
Crear un texto con formato condicional al cumplirse ciertos requisitos en excel vba
1 respuesta más de otro experto
Esta es la imagen inicial de tu planteamiento como ves el texto esta separado por una diagonal
este es el resultado parcial de la macro aquí se abre un inputbox y vas marcando las celdas destino, seleccionas con el maouse ypones una coma de separador
después de eso la macro asigna a esas celdas los valores, solo quedaría definir cuantos valores quieres por rango, esto lo jhice a manera de ejemplo
y este es el código sorry si es mucho código trate de usar la menor cantidad de código posible
Sub SEPARAR()
Application.DisplayAlerts = False
Range("A1").CurrentRegion.Replace WHAT:="/", REPLACEMENT:=" "
MATRIZ = Range("A1").CurrentRegion
MATRIZ = Application.Transpose(Application.Transpose(Split(Join(Application.Transpose(MATRIZ), " "), " ")))
On Error Resume Next
Set RANGOS = Application.InputBox(PROMPT:="SELECCIONA LAS CELDAS DONDE COLOCAR LOS RANGOS", Type:=8)
If Err.Number > 0 Then MsgBox ("TECLE UN RANGO"): End
On Error GoTo 0
CELDAS = RANGOS.Address
SEPARA = Application.Transpose(Application.Transpose(Split(CELDAS, ",")))
FILAS = UBound(SEPARA)
FILAS2 = UBound(MATRIZ)
RENGLONES = WorksheetFunction.Quotient(FILAS2, FILAS)
For I = 1 To FILAS
If I = 1 Then
Set DATOS = Range(SEPARA(1)).Resize(FILAS2, 1)
Range(DATOS.Address) = Application.Transpose(MATRIZ)
Else
FILAS2 = DATOS.CurrentRegion.Rows.Count
Set DATOS = DATOS.Rows(FILAS + 1).Resize(FILAS2 - FILAS)
DATOS.Copy
Range(SEPARA(I)).PasteSpecial xlPasteValues
DATOS.Clear
Set DATOS = Range(SEPARA(I)).CurrentRegion
End If
Next I
Application.DisplayAlerts = True
End Sub