AYUDA CON MACRO DIFICL

[sebas597]

Buenos días, espero alguien pueda ayudarme, estoy perdido en esto.

Tengo una tabla con 9 columnas y 200 filas.

En la columna A, que es la numero 1 hay un código de informe.
En la columna I, que es la numero 9,  se pueden ver los siguientes elementos: UNV, AVP, UDV, PLV. Cada uno de estos conjuntos de tres letras son una Unidad de Negocio a las que reporta cada informe.

 

El problema  surge cuando un informe de la columna A reporta a más de una Unidad de Negocio, como sucede en la fila 12, por ejemplo.

 

Necesito que en todas las celdas de la columna 9 haya solamente una Unidad de Negocio: UNV, AVP, UDV, PLV. 

Para ello necesito que en las celdas de la columna 9 en las que hay más de una Unidad de Negocio, se separen en filas, una debajo de otra, todas las Unidades de Negocio que haya en la celda, y que el contenido del resto de la fila original se copie tal cual. 

Aquellas que tengan más de una UN, separadas por el delimitador " , " necesito que se cree inmediatamente debajo de la fila original, una fila por cada una de las UN que haya en la celda de la columna 9.

En las filas de la columna 9 que solo haya una UN, no hay que hacer nada.

Hasta ahora tengo una macro, pero al ejecutarla se cierra Excel. Lo he probado en tres ordenadores, y pasa lo mismo.

Hay algo mal en la Macro? No está bien definido el rango y por eso se cuelga? Espero que alguien pueda ayudarme porfavor.

 

Sub DividirEmpresas()

'Obtenemos la celda inicial
Dim Celda As Range
Set Celda = Range("I2")

'Recorremos todas las celdas de la columna 9
Do While Celda.Column = 9

'Obtenemos la matriz de empresas
Dim Matriz As Variant
Matriz = Split(Celda.Value, " | ")

'Si la matriz contiene más de una empresa
If UBound(Matriz) > 1 Then

'Recorremos la matriz de empresas
For Each Empresa In Matriz

'Obtenemos la fila actual
Dim FilaActual As Long
FilaActual = Celda.Row

'Insertamos una nueva fila
Application.InsertRows FilaActual, 1

'Asignamos el valor de la empresa a la celda
Cells(FilaActual + 1, 1).Value = Empresa

'Copiamos el contenido de las otras celdas de la fila
For i = 2 To Celda.Columns.Count
Cells(FilaActual + 1, i).Value = Cells(FilaActual, i).Value
Next

Next

End If

'Avanzamos a la siguiente celda
Celda.Offset(1, 0).Select
Loop

End Sub
 

[Antoni]

Prueba la macro:

Sub DividirEmpresas()
Dim UND As Variant, x As Long, u As Integer
Application.ScreenUpdating = False
For x = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
   UND = Split(Range("I" & x), ",")
   If UBound(UND) > 0 Then
      For u = UBound(UND) To 0 Step -1
         Rows(x + 1).Insert
         Range("A" & x).Resize(1, 8).Copy Range("A" & x + 1)
         Range("I" & x + 1) = UND(u)
      Next
      Rows(x).Delete
   End If
Next
End Sub

 

[sebas597]

hace 48 minutos , Antoni dijo:

Prueba la macro:

Sub DividirEmpresas()
Dim UND As Variant, x As Long, u As Integer
Application.ScreenUpdating = False
For x = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
   UND = Split(Range("I" & x), ",")
   If UBound(UND) > 0 Then
      For u = UBound(UND) To 0 Step -1
         Rows(x + 1).Insert
         Range("A" & x).Resize(1, 8).Copy Range("A" & x + 1)
         Range("I" & x + 1) = UND(u)
      Next
      Rows(x).Delete
   End If
Next
End Sub

 

Ha funcionado a la primera 😵.
Muchísimas gracias, de verdad, te lo agradezco un montón.

Estoy mejorando en Excel y seguro que este foro, el cual no conocía me será de ayuda para aprender y ayudar a quien lo necesite.