Cómo combinar celdas mediante VBA
Os pongo en situación:
Cada semana me pasan un reporte en Excel con un formato concreto, y tengo que modificarlo para darle otro formato de "salida", así que harto de repetirlo me he lanzado a la piscina para intentar hacer una macro que me solvente el problema en segundos (sin contar las horas de programación XD )
El report que me pasan a mi es del tipo:
y necesito dar un formato de salida, obviando colores y formatos..
Vamos, que el campo del artículo que me viene como un churro, desmontarlo y que para una referencia haya N artículos.
Eso lo he conseguido de forma bastante peregrina, ya que soy muy nuevo en VBA, pero lo que no consigo es lo de combinar las celdas.
He probado de crear mediante la grabadora de macros el código, pero nada. También he visto por varios foros la sentencia:
Range("C10:D10").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
El problema, es que tal y como lo tengo montado, el formato de las celdas en el código no lo tengo como A1, sino como (1,1), y como podrís ver en la segunda foto, el rango variaría según el número de artículos que tenga esa referencia. He probado varias cosas, pero siempre me da error al llegar a ese punto.
Os dejo el código que he hecho hasta ahora (por favor, que nadie se arranque los ojos ni se eche a llorar, que ya he dicho que soy muy nuevo) XD
Sub transformar()
Dim celda As Range
Dim rango As Range
Dim poscoma, lencadena As String
Dim cadena, codigo, nuevafila As String
Dim numeroactas As String
numeroactas = Cells(2, 10).Value
'cabeceras
Sheets("Resumen").Range("b2").Value = Sheets("Autoritas").Range("b2").Value
Sheets("Resumen").Range("c2").Value = Sheets("Autoritas").Range("c2").Value & " y " & Sheets("Autoritas").Range("d2").Value
Sheets("Resumen").Range("d2").Value = Sheets("Autoritas").Range("e2").Value
Sheets("Resumen").Range("e2").Value = Sheets("Autoritas").Range("f2").Value
'copiar registros
j = 0 'acumulador de nuevas filas
For i = 3 To (numeroactas + 2)
nuevafila = i + j
poscoma = 0
lencadena = 0
celdacombinainicio = ""
celdacombinafinal = ""
Sheets("Resumen").Cells(nuevafila, 2).Value = Sheets("Autoritas").Cells(i, 2).Value
Sheets("Resumen").Cells(nuevafila, 3).Value = Sheets("Autoritas").Cells(i, 3).Value & " " & Sheets("Autoritas").Cells(i, 4).Value
Sheets("Resumen").Cells(nuevafila, 4).Value = Sheets("Autoritas").Cells(i, 5).Value
' desmontar cadena de artículos
cadena = Sheets("Autoritas").Cells(i, 6).Value
codigo = ""
poscoma = InStr(cadena, ",")
If poscoma > 0 Then
Do While Len(cadena) > 4
codigo = Left(cadena, poscoma - 1)
cadena = Mid(cadena, poscoma + 1, Len(cadena) - poscoma + 1)
Sheets("Resumen").Cells(i + j, 5).Value = codigo
poscoma = InStr(cadena, ",")
j = j + 1
If Len(cadena) = 4 Then
Sheets("Resumen").Cells(i + j, 5).Value = cadena
End If
Loop
Else
Sheets("Resumen").Cells(nuevafila, 5).Value = cadena
End If
' combinar celdas
' Range("C10:D10").Select
' With Selection
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlCenter
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .ShrinkToFit = False
' .MergeCells = True
' End With
Next i
End Sub
1 Respuesta
Para empezar las variables que correspondan a nros de filas las vamos a declararla como Integer o Long.
Dim nuevafila As Long, ini As Long, fini As Long
Las variables ini y fini las utilizo para indicar cuál es el rango de cada registro original.
Al finalizar con todo el pase le asigno bordes al rango completo.
Sub transformar()
Dim celda As Range
Dim rango As Range
Dim poscoma, lencadena As String
Dim cadena, codigo
Dim numeroactas As String
Dim nuevafila As Long, ini As Long, fini As Long
numeroactas = Cells(2, 10).Value
'cabeceras
Sheets("Resumen").Range("b2").Value = Sheets("Autoritas").Range("b2").Value
Sheets("Resumen").Range("c2").Value = Sheets("Autoritas").Range("c2").Value & " y " & Sheets("Autoritas").Range("d2").Value
Sheets("Resumen").Range("d2").Value = Sheets("Autoritas").Range("e2").Value
Sheets("Resumen").Range("e2").Value = Sheets("Autoritas").Range("f2").Value
'copiar registros
j = 0 'acumulador de nuevas filas
For i = 3 To (numeroactas + 2)
nuevafila = i + j
poscoma = 0
lencadena = 0
celdacombinainicio = ""
celdacombinafinal = ""
Sheets("Resumen").Cells(nuevafila, 2).Value = Sheets("Autoritas").Cells(i, 2).Value
Sheets("Resumen").Cells(nuevafila, 3).Value = Sheets("Autoritas").Cells(i, 3).Value & " " & Sheets("Autoritas").Cells(i, 4).Value
Sheets("Resumen").Cells(nuevafila, 4).Value = Sheets("Autoritas").Cells(i, 5).Value
ini = nuevafila 'EM: 1er fila del registro de origen
' desmontar cadena de artículos
cadena = Sheets("Autoritas").Cells(i, 6).Value
codigo = ""
poscoma = InStr(cadena, ",")
If poscoma > 0 Then
Do While Len(cadena) > 4
codigo = Left(cadena, poscoma - 1)
cadena = Mid(cadena, poscoma + 1, Len(cadena) - poscoma + 1)
Sheets("Resumen").Cells(i + j, 5).Value = codigo
poscoma = InStr(cadena, ",")
j = j + 1
If Len(cadena) = 4 Then
Sheets("Resumen").Cells(i + j, 5).Value = cadena
End If
Loop
fini = i + j 'EM: última fila para el registro
Else
Sheets("Resumen").Cells(nuevafila, 5).Value = cadena
fini = nuevafila 'E:indico en la variable cuál fue la últ fila
End If
'EM: si hay + de 1 fila se combina
If fini > ini Then
With Sheets("Resumen").Range("B" & ini & ":B" & fini)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
With Sheets("Resumen").Range("C" & ini & ":C" & fini)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
With Sheets("Resumen").Range("D" & ini & ":D" & fini)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
End With
End If
Next i
'EM: aplica bordes a todo el rango. 1er fila = 2, últ = fini
With Sheets("Resumen").Range("B2:E" & fini)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
MsgBox "Fin del proceso."
'opcional: pasar a hoja Resumen
Sheets("Resumen").Select
End SubQuizás tengas que ajustar también el formato de la celda Fecha/horas.... depende de cómo aparece en tu origen.
