VBA Para Cada, Copiar desplazamiento y pegar en el siguiente espacio en una columna
Tengo una tabla que se ha estropeado debido a una conversión de tipo de archivo. Hay muchas filas y columnas en blanco y quiero limpiarla y extraer la información que necesito. Recibo este informe regularmente, por lo que me gustaría automatizar este proceso.
Quiero buscar en la columna “C” la palabra “Parte” y, cuando encuentre cada instancia de ella, quiero “Mover hacia arriba 1 y hacia la derecha 3”, copiar esa celda y agregarla a una lista en la columna “A” de otra pestaña.
A continuación se muestra mi código, cuando se ejecuta, no sucede nada. Ni siquiera aparece un mensaje de error.
Sub ActualizacióndePreciosEPICS()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Hoja1")
Worksheets("Hoja1").Cells.UnMerge
Worksheets("Hoja1").Range("A:AZ").RowHeight = 15
Worksheets("Hoja1").Range("A:AZ").ColumnWidth = 4
Worksheets("Hoja1").Cells.Font.Name = "Calibri"
Worksheets("Hoja1").Cells.Font.Size = 11
Worksheets("Hoja1").Cells.Font.Bold = False
Worksheets("Hoja1").Cells.Font.Italic = False
Worksheets("Hoja1").Cells.Font.Underline = False
'Worksheets("Hoja1").Borders.LineStyle = xlNone
Worksheets("Salida").Range("A1") = "Número de Parte"
Worksheets("Salida").Range("B1") = "Número de Troquel"
Worksheets("Salida").Range("C1") = "Longitud"
Worksheets("Salida").Range("D1") = "Peso"
Worksheets("Salida").Range("E1") = "Precio"
Dim ptn As Range
Dim cel As Range
Dim Rptn As Range
Set Rptn = Worksheets("Salida").Cells(Rows.Count, 1).End(xlUp) 'última celda en la columna A con datos
Set ptn = Worksheets("Hoja1").Range("C1", Worksheets("Hoja1").Range("C" & ActiveSheet.Rows.Count).End(xlUp))
For Each cel In ptn
If cel.Value = "Parte" Then
cel.Value.Offset(1, 3).Copy Destination:=Worksheets("Salida").Range("A1").End(xlDown).Offset(1)
End If
Next cel
End Sub
davy.ai
El problema con el código puede ser porque la palabra “PART” está en mayúsculas y el código está buscando “Part” en minúsculas. Cambie la condición en la declaración If a
If LCase(cel.Value) = "part" Then
para que sea insensible a mayúsculas y minúsculas.Además, la línea
Set Rptn = Worksheets("Output").Cells(Rows.Count, 1).End(xlUp)
puede causar un error porque asume que la hoja activa es “Output”. Cambíela aSet Rptn = Worksheets("Output").Cells(Worksheets("Output").Rows.Count, 1).End(xlUp)
para hacer referencia explícitamente a la hoja “Output”.Por último, la línea
cel.Value.Offset(1, 3).Copy Destination:=Worksheets("Output").Range("A1").End(xlDown).Offset(1)
puede no funcionar como se espera porque solo copia una celda y la pega en la siguiente fila disponible en la columna A. Cambíela acel.Offset(-1, 0).Resize(, 5).Copy Destination:=Rptn.Offset(1, 0)
para copiar la fila que contiene “PART” y pegarla en la siguiente fila vacía de la hoja “Output”.El código final debería verse así: