es.davy.ai

Preguntas y respuestas de programación confiables

¿Tienes una pregunta?

Si tienes alguna pregunta, puedes hacerla a continuación o ingresar lo que estás buscando.

VBA Para Cada, Copiar desplazamiento y pegar en el siguiente espacio en una columna

05 Aug, 2023 Programación

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
Tags:  ,

Answer

  1. Avatar for davy.ai
    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 a Set 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 a cel.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í:

    Sub EPICSPriceUpdate()

Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

Worksheets("Sheet1").Cells.UnMerge
Worksheets("Sheet1").Range("A:AZ").RowHeight = 15
Worksheets("Sheet1").Range("A:AZ").ColumnWidth = 4
Worksheets("Sheet1").Cells.Font.Name = "Calibri"
Worksheets("Sheet1").Cells.Font.Size = 11
Worksheets("Sheet1").Cells.Font.Bold = False
Worksheets("Sheet1").Cells.Font.Italic = False
Worksheets("Sheet1").Cells.Font.Underline = False
'Worksheets("Sheet1").Borders.LineStyle = xlNone

Worksheets("Output").Range("A1") = "Número de Pieza"
Worksheets("Output").Range("B1") = "Número de Molde"
Worksheets("Output").Range("C1") = "Longitud"
Worksheets("Output").Range("D1") = "Peso"
Worksheets("Output").Range("E1") = "Precio"

Dim ptn As Range
Dim cel As Range
Dim Rptn As Range


Set Rptn = Worksheets("Output").Cells(Worksheets("Output").Rows.Count, 1).End(xlUp) 'última celda en la columna A con datos
Set ptn = Worksheets("Sheet1").Range("C1", Worksheets("Sheet1").Range("C" & ActiveSheet.Rows.Count).End(xlUp))

For Each cel In ptn
    If LCase(cel.Value) = "part" Then
        cel.Offset(-1, 0).Resize(, 5).Copy Destination:=Rptn.Offset(1, 0)
        Set Rptn = Rptn.Offset(1, 0)
    End If
Next cel

End Sub

Comments are closed.