Macro para igualar las longitudes de columnas con ceros

[xkudsraw]

Buenos días foreros:

Tengo un problemilla que creo que se podría resolver con un par de líneas de programación.

He realizado una serie de medidas (Medidas 1, 2 y 3) que consisten en valores de coeficientes de fricción para un número fijo de frenadas por medida. El número de valores varía ligeramente ya que no todas las frenadas duran lo mismo. Esto es lo que resulta un problema para su representación después. Me gustaría que el número de valores por frenada fuese igual (aunque de una frenada a otra puede ser diferente, por ejemplo, la 2 puede tener 30 valores y la 5 puede tener 50) y podría valerme añadir ceros hasta igualar la longitud de las frenadas más cortas con la de máxima duración. (En el archivo de ejemplo sería convertir la tabla1 en la tabla2)

¿Alguien conoce alguna macro que pueda hacer esto fácilmente? Mi problema es que no conozco VBA ni la terminología de Excel para manejar las celdas, columnas (p.ej. buscar el máximo, conocer las coordenadas de una celda, añadir celdas nuevas...). Si alguien tiene un comentario, ejemplo, contraejemplo o sugerencia, que me lo haga llegar

 

Un saludo

ejemplo.xlsx

ejemplo.xlsx

[Antoni]

Prueba con esta macro.

Vale para cualquier número de filas y columnas.

Cita

Sub Alinear()
Dim Máx() As Long, Columnas As Integer
Application.ScreenUpdating = False
Hoja1.Cells.Copy Hoja2.Cells
Columnas = Hoja2.Range("A2").End(xlToRight).Column
ReDim Máx(Columnas / 2)
fila = 3
x = 3
Do
   For y = 2 To Columnas Step 2
      x = fila
      n = 1
      Do Until Hoja2.Cells(x, y) <> Hoja2.Cells(x + 1, y)
         x = x + 1
         n = n + 1
      Loop
      Máx(y / 2) = n
      If maxi < n Then maxi = n
   Next
   For y = 1 To UBound(Máx)
      If Máx(y) < maxi Then
         i = fila + Máx(y)
         f = fila + maxi - 1
         Hoja2.Range(Hoja2.Cells(i, (y - 1) * 2 + 1), _
                     Hoja2.Cells(f, y * 2)).Insert Shift:=xlDown
         For x = i To f
            Hoja2.Cells(x, (y - 1) * 2 + 1) = 0
            Hoja2.Cells(x, y * 2) = Hoja2.Cells(x - 1, y * 2)
         Next
      End If
   Next
   fila = f + 1
Loop Until Hoja2.Cells(fila, 1) = ""
Hoja2.Select
End Sub

 

 

[xkudsraw]

¡Muchas gracias!

Tiene buena pinta. Al final ayer llegamos un compañero y yo a una solución muy similar. La pego abajo

[xkudsraw]

Sub zellen_hinzufügen_und_ausfüllen()
'
' zellen_hinzufügen_und_ausfüllen Makro
'

With Application

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

 
  icol = Range("A3").End(xlToRight).Column

  irow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row

  For crow = 3 To irow
 
  br_min = 9999999
 
  For ccol = 1 To icol Step 2
  'condition for adding a new row
 
    If Cells(crow, ccol + 1) < br_min And Cells(crow, ccol + 1) > 0 Then
    br_min = Cells(crow, ccol + 1)
    End If
    
  Next ccol
    
  For ccol = 1 To icol Step 2
     
    If Not Cells(crow, ccol + 1) = br_min Then
    
    
    Range(Cells(crow, ccol), Cells(crow, ccol + 1)).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Cells(crow, ccol).Value = 0
    Cells(crow, ccol + 1).Value = Cells(crow - 1, ccol + 1).Value
      
    End If
 
  Next ccol
 
  If crow = irow Then irow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row

  Next crow

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

 

 End With
End Sub

 

[xkudsraw]

Donde más problemas tuvimos fue para encontrar la fila máxima... que no siempre coincidía en la primera columna. Al final está resuelto con un "find" que tiene pinta de ser bastante costoso computacionalmente.

Creo que el "do while" de la solución propuesta es bastante más efectivo, ¿no?

[Antoni]

Como dice el refrán:

"Ni mejor, ni peor, sino todo lo contrario" 

 

.