Attribute VB_Name = "Module1"
Option Explicit
Sub SplitBOM()
' hiker95, 02/13/2012
' http://www.mrexcel.com/forum/excel-questions/613198-split-bom-reference-designators.html
Dim itemColumnIndex As Long: itemColumnIndex = 1
Dim quantityColumnIndex As Long: quantityColumnIndex = 3
Dim referenceColumnIndex As Long: referenceColumnIndex = 4
Dim rowStartIndex As Long: rowStartIndex = 2
Dim r As Long, c As Long, i As Long, maxRowIndex As Long, maxColumnIndex As Long, referenceSplit, n As Long
Dim initialQuantitySum As Long: initialQuantitySum = 0
Dim resultQuantitySum As Long: resultQuantitySum = 0
Dim hasError As Boolean: hasError = False
Dim xLen As Long
Dim xStr As String
Application.ScreenUpdating = False
' Unión de referencias por Item:
' Recorre todas las filas desde el inicio (omitiendo la cabecera) y comprueba si la columna de cantidad
' está vacía. Si es así, incluye el valor de la columna de referencia en la linea anterior
maxRowIndex = Cells(Rows.Count, referenceColumnIndex).End(xlUp).Row
For r = rowStartIndex To maxRowIndex Step 1
' Se aprovecha este bucle para sumar la cantidad total del BOM
If Cells(r, quantityColumnIndex) <> "" Then
initialQuantitySum = initialQuantitySum + Cells(r, quantityColumnIndex)
End If
If Cells(r, referenceColumnIndex) = "" Then
' Si la celda de referencia está vacía no hace nada
ElseIf Cells(r, quantityColumnIndex) = "" Then
Cells(r - 1, referenceColumnIndex).Value = Cells(r - 1, referenceColumnIndex).Value + Cells(r, referenceColumnIndex).Value
Cells(r, referenceColumnIndex).EntireRow.Delete
r = r - 1
End If
Next r
' Orden de la celda de referencia inicial
Columns(referenceColumnIndex + 1).Insert
Columns(referenceColumnIndex + 1).Insert
maxColumnIndex = Cells(1, Columns.Count).End(xlToLeft).Column
maxRowIndex = Cells(Rows.Count, referenceColumnIndex).End(xlUp).Row
For r = rowStartIndex To maxRowIndex Step 1
xLen = VBA.Len(Cells(r, referenceColumnIndex).Value)
' Por cada uno de los caracteres de la celda de referencia se separan las letras y números en las celdas temporales insertadas
For i = 1 To xLen
xStr = VBA.Mid(Cells(r, referenceColumnIndex).Value, i, 1)
' Si el valor es una coma se pone en ambas celdas para seguir con la separación
' Si es un número, se añade a a 2º celda insertada, si no a la 1º.
If xStr = "," Then
Cells(r, referenceColumnIndex + 1).Value = Cells(r, referenceColumnIndex + 1).Value + "_"
Cells(r, referenceColumnIndex + 2).Value = CStr(Cells(r, referenceColumnIndex + 2).Value) + "_"
ElseIf VBA.IsNumeric(xStr) Then
Cells(r, referenceColumnIndex + 2).Value = CStr(Cells(r, referenceColumnIndex + 2).Value) + CStr(xStr)
Else
Cells(r, referenceColumnIndex + 1).Value = Cells(r, referenceColumnIndex + 1).Value + xStr
End If
Next i
' Si la celda de números tiene algún valor y además hay alguna coma (es decir, hay más de uno), ordena los valores de dentro de la celda numéricamente
If Cells(r, referenceColumnIndex + 2) <> "" And InStr(Cells(r, referenceColumnIndex + 2), "_") <> 0 Then
SortVals r, referenceColumnIndex + 2, "_"
Cells(r, referenceColumnIndex + 1) = Split(Cells(r, referenceColumnIndex + 1), "_")(0)
Cells(r, referenceColumnIndex + 2) = Split(Cells(r, referenceColumnIndex + 2), "_")(0)
End If
Next r
' Una vez separados caracteres y números en diferentes celdas, se ordena la tabla por ambas columnas y después se eliminan
Cells.Sort _
Key1:=Columns(referenceColumnIndex + 1), order1:=xlAscending, DataOption1:=xlSortNormal, _
key2:=Columns(referenceColumnIndex + 2), order2:=xlAscending, DataOption2:=xlSortNormal, _
Header:=xlYes
Columns(referenceColumnIndex + 1).Delete
Columns(referenceColumnIndex + 1).Delete
' Separación de valores de la columna de referencia:
' Recorre el listado desde abajo, añadiendo tantas filas como referencias existan (separadas por coma).
' La columna de cantidad debería resultar 1, si no es así significa que el valor inicial no concuerda con el
' número de referencias separadas por comas.
' Copia los valores del resto de columnas en las filas añadidas.
maxColumnIndex = Cells(1, Columns.Count).End(xlToLeft).Column
maxRowIndex = Cells(Rows.Count, referenceColumnIndex).End(xlUp).Row
For r = maxRowIndex To rowStartIndex Step -1
If Cells(r, referenceColumnIndex) = "" Or InStr(Cells(r, referenceColumnIndex), ",") = 0 Then
' Si la celda de referencia está vacía o no tiene ninguna coma no hay que hacer nada con esta fila
ElseIf InStr(Cells(r, referenceColumnIndex), ",") > 0 Then
referenceSplit = Split(Trim(Cells(r, referenceColumnIndex)), ",")
Rows(r + 1).Resize(UBound(referenceSplit)).Insert
For c = 1 To maxColumnIndex Step 1
If c = quantityColumnIndex Or c = referenceColumnIndex Then
' Si la columna es la de cantidad o referencia, no hace nada
Else
Cells(r, c).Resize(UBound(referenceSplit) + 1).Value = Cells(r, c).Value
End If
Next c
'
Cells(r, quantityColumnIndex).Resize(UBound(referenceSplit) + 1) = Cells(r, quantityColumnIndex) / (UBound(referenceSplit) + 1)
Cells(r, referenceColumnIndex).Resize(UBound(referenceSplit) + 1) = Application.Transpose(referenceSplit)
End If
Next r
' Eliminación de espacios en la celda de referencia
maxRowIndex = Cells(Rows.Count, referenceColumnIndex).End(xlUp).Row
For r = rowStartIndex To maxRowIndex Step 1
Cells(r, referenceColumnIndex).Value = Replace(Cells(r, referenceColumnIndex).Value, " ", "")
Next r
' Comprobación de errores:
' Se comprueba que en todas las celdas de cantidad el resultado haya sido 1, si no es así significa que
' la cantidad inicial no era igual al número de referencias separadas por comas.
' También se comprueba que la suma de todas las cantidades sea igual a la suma inicial.
For r = rowStartIndex To maxRowIndex Step 1
If Cells(r, quantityColumnIndex) <> "" And Cells(r, quantityColumnIndex) <> 1 Then
hasError = True
Exit For
End If
resultQuantitySum = resultQuantitySum + Cells(r, quantityColumnIndex)
Next r
If hasError Then
MsgBox "Error en la linea " & r & ", la cantidad inicial no correspondía con el número de referencias existentes"
Rows(r).Select
ActiveWindow.ScrollRow = Selection.Row
ElseIf initialQuantitySum <> resultQuantitySum Then
MsgBox "La suma de las cantidades (" & initialQuantitySum & ") es distinta a la suma inicial (" & resultQuantitySum & ")"
End If
' Orden por referencia final
Columns(referenceColumnIndex + 1).Insert
Columns(referenceColumnIndex + 1).Insert
Dim previousItem As String
Dim currentItemIndex As Long: currentItemIndex = 0
' Similar al orden inicial, solo que esta vez, al haber ya pre-ordenado los items según su referencia más alta,
' sólo hay que reordenar dentro de cada item
For r = rowStartIndex To maxRowIndex Step 1
xLen = VBA.Len(Cells(r, referenceColumnIndex).Value)
' Si cambia el valor de la columna de item, se suma +1 al índice del item actual
If Cells(r, itemColumnIndex).Value <> previousItem Then
previousItem = Cells(r, itemColumnIndex).Value
currentItemIndex = currentItemIndex + 1
End If
For i = 1 To xLen
xStr = VBA.Mid(Cells(r, referenceColumnIndex).Value, i, 1)
If VBA.IsNumeric(xStr) Then
Cells(r, referenceColumnIndex + 2).Value = CStr(Cells(r, referenceColumnIndex + 2).Value) + CStr(xStr)
Else
Cells(r, referenceColumnIndex + 1).Value = Cells(r, referenceColumnIndex + 1).Value + xStr
End If
Next i
' A la columna temporal con la letra se le añade el índice del item para que, a la hora de reordenar, no mezcle los items con mismo carácter de referencia
If Cells(r, referenceColumnIndex + 1).Value <> "" Then
Cells(r, referenceColumnIndex + 1).Value = Cells(r, referenceColumnIndex + 1).Value + Format(currentItemIndex, "000000")
End If
Next r
Cells.Sort _
Key1:=Columns(referenceColumnIndex + 1), order1:=xlAscending, DataOption1:=xlSortNormal, _
key2:=Columns(referenceColumnIndex + 2), order2:=xlAscending, DataOption2:=xlSortNormal, _
Header:=xlYes
Columns(referenceColumnIndex + 1).Delete
Columns(referenceColumnIndex + 1).Delete
Application.ScreenUpdating = True
End Sub
Public Sub SortVals(rowIndex As Long, columnIndex As Long, separator As String)
Dim i As Integer
Dim arr As Variant
arr = Split(Cells(rowIndex, columnIndex).Text, separator)
' trim values so sort will work properly
For i = LBound(arr) To UBound(arr)
arr(i) = Format(Trim(arr(i)), "0000000")
Next i
' sort
QuickSort arr, LBound(arr), UBound(arr)
' load sorted values back to cell
Dim nextSeparator As String: nextSeparator = ""
Cells(rowIndex, columnIndex) = ""
For i = LBound(arr) To UBound(arr)
Cells(rowIndex, columnIndex) = Cells(rowIndex, columnIndex) & nextSeparator & CStr(arr(i))
nextSeparator = separator
Next i
End Sub
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHi
pivot = vArray((inLow + inHi) \ 2)
While (tmpLow <= tmpHi)
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend
While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend
If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub
