Copiar filas a otro libro de trabajo en función de si una celda contiene un valor/condición numérico: isnumeric = true

Resuelto Anthony Davis SF asked hace 11 meses • 0 respuestas

Todavía soy novato y he tenido un éxito accidental mientras escribía esta publicación, pero aún así la publicaré en un intento de aprender más sobre el filtro automático y cómo funcionan las referencias condicionales dentro de bucles/otras cosas condicionales. Además, espero que esta publicación pueda ayudar a alguien más.

Estoy intentando escribir una macro de VBA que copiará filas del libro1 al libro2 en función de si la celda N(x) de la fila que se va a copiar tiene un valor numérico o no. Básicamente, estoy tratando de crear una base de datos que rastree si recibimos muestras sobrantes que luego almacenamos internamente.

En el libro de trabajo 1, si el valor del número de muestras recibidas es mayor que el número enviado, el resto se muestra en la columna "N". Si no, devuelve "". Me gustaría copiar cualquier fila que devuelva un valor en la columna N al libro de trabajo2.

Encontré un montón de publicaciones sobre cómo copiar filas según las condiciones, pero parece que no puedo hacer que el código funcione cuando lo modifico. A continuación se muestran dos ejemplos de código incompleto que intenté modificar. (Accidentalmente completé el segundo código mientras escribía esta publicación, pero no estoy seguro de por qué de repente funciona ahora...)

Sub ESWcopypaste()

    Dim ESW As Workbook, AW As Workbook, Awksht As Worksheet, ESwksht As Worksheet
    Dim LR As Long, i As Long
    Dim R As Range

    Set AW = ThisWorkbook
    Set Awksht = AW.Worksheets("RECORDS")
    Set R = Awksht.Range([A2], Range("A" & Rows.Count).End(xlUp)) <-"Have tried a few variations here. I still have a problem where it reads a cell with a formula that returns "" as numeric and includes them in the count..."

    Workbooks.Open ("filepath to the ESW workbook")
    Set ESW = Application.Workbooks("Extra Samples Catalog.xlsm")
    Set ESwksht = ESW.Worksheets(3)

    CR = ESwksht.Range("A" & Rows.Count).End(xlUp).Row <- "will be used to locate empty space to paste the contents, possible unnecessary when using autofilter"

    On Error Resume Next
        With R
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To LR
            .AutoFilter , field:=1, Criteria1:=(If IsNumeric(Range("N" & i).Value) = True)
            .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                Sheets("ESwksht").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .AutoFilter
        End With
    On Error GoTo 0

End Sub

El código anterior se basa en la publicación vinculada a continuación. Parece que no puedo entender cómo convertir los criterios de filtro en una versión funcional de este "Criterio1:=(If IsNumeric(Range("N" & i).Value) = True)", que no es correcto, solo yo apreto el teclado en un intento de hacerlo funcionar... https://www.mrexcel.com/board/threads/help-need-vba-code-to-copy-rows-to-a-new-worksheet -basado en criterios.359760/

Mi primer intento fue utilizar copiar y pegar condicional. Se estaba atascando en la línea para pegar, lo que me mostraba un mensaje de error 13 que no coincide. Cambié

ESwksht.Range(R).Offset(1).PasteSpecial Paste:=xlPasteValues

ESwksht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

y ahora funciona, aunque no sé por qué... El código de trabajo se encuentra a continuación.

Sub CPESampleData()

    Dim ESW As Workbook, AW As Workbook, Awksht As Worksheet, ESwksht As Worksheet
    Dim LR As Long, i As Long
    Dim R As Range

    Set AW = ThisWorkbook
    Set Awksht = AW.Worksheets("RECORDS")
    Set R = Awksht.Range("A" & Rows.Count).End(xlUp)

    Workbooks.Open ("C:filepath to Extra Samples Catalog.xlsm")
    Set ESW = Application.Workbooks("Extra Samples Catalog.xlsm")
    Set ESwksht = ESW.Worksheets(3)
    CR = ESwksht.Range("A" & Rows.Count).End(xlUp).Row

    AW.Activate

    With AW.Sheets("RECORDS")
        AW.Activate
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To LR
            If IsNumeric(Range("N" & i).Value) = True Then
                Awksht.Rows(i).Copy
                ESwksht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            End If
        Next i
    End With

    ESwksht.Activate

End Sub

El código anterior fue modificado a partir de estas dos publicaciones. https://www.mrexcel.com/board/threads/vba-conditional-copy-paste.468926/ VBA copia filas que cumplen con los criterios en otra hoja

Feb 17 '24 04:02 Anthony Davis SF

Aceptado

Copiar filas filtradas a otro libro de trabajo

Copiar filas con un número en la columna (solo valores)

En VBA, una celda se considera numérica incluso si está vacía, es decir, si se cumple lo siguiente: en VBA IsEmpty(Range("A1").Value)o su equivalente en Excel ISBLANK(A1).
Cuando no tienes celdas vacías, está bien usarlo, IsNumeric(Range("A1").Value)pero prefiero el más seguro (más preciso) VarType(Range("A1").Value) = vbDouble.

Sub CopyIfNumberRows()
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets("RECORDS")
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
    Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    Dim Data As Variant: Data = sdrg.Value
    Dim cCount As Long: cCount = UBound(Data, 2)
    
    Dim sr As Long, dr As Long, c As Long, WasDataCopied As Boolean
    
    For sr = 1 To UBound(Data, 1)
        If VarType(Data(sr, 14)) = vbDouble Then ' is a number
            dr = dr + 1
            For c = 1 To cCount
                Data(dr, c) = Data(sr, c)
            Next c
        End If
    Next sr
    
    If dr = 0 Then GoTo WriteMessage

    Application.ScreenUpdating = False
    
    Dim dwb As Workbook:
    Set dwb = Workbooks.Open("C:\Test\Extra Samples Catalog.xlsm")
    Dim dws As Worksheet: Set dws = dwb.Worksheets(3)
    Dim dfcell As Range:
    Set dfcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    Dim drg As Range: Set drg = dfcell.Resize(dr, cCount)
    
    drg.Value = Data

    'dwb.Close SaveChanges:=True

    Application.ScreenUpdating = True

    WasDataCopied = True
    
WriteMessage:
    
    If WasDataCopied Then
        MsgBox "If-number rows copied.", vbInformation
    Else
        MsgBox "No if-number rows found.", vbExclamation
    End If

End Sub

Copiar filas con celdas no lancadas en columna (valores, formato y fórmulas)

Sub CopyNonBlanksAutoFilter()
    
    Application.ScreenUpdating = False

    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets("RECORDS")
    sws.AutoFilterMode = False
    Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
    Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    
    Dim svrg As Range, WasDataCopied As Boolean
    
    strg.AutoFilter Field:=14, Criteria1:="<>"
    On Error Resume Next
        Set svrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    sws.AutoFilterMode = False
    
    If svrg Is Nothing Then GoTo WriteMessage
    
    Dim dwb As Workbook:
    Set dwb = Workbooks.Open("C:\Test\Extra Samples Catalog.xlsm")
    Dim dws As Worksheet: Set dws = dwb.Worksheets(3)
    Dim dfcell As Range:
    Set dfcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    
    svrg.Copy dfcell
    
    'dwb.Close SaveChanges:=True
    
    WasDataCopied = True
    
WriteMessage:
    
    Application.ScreenUpdating = True
    
    If WasDataCopied Then
        MsgBox "Non-blanks copied.", vbInformation
    Else
        MsgBox "No non-blanks found.", vbExclamation
    End If

End Sub

Feb 16 '2024 22:02 VBasic2008