excel - Copie los datos filtrados a otra hoja usando VBA

excel-vba filter

Question

Tengo dos sabanas. Uno tiene los datos completos y el otro se basa en el filtro aplicado en la primera hoja.

Nombre de la hoja de datos: Data
Nombre de la hoja filtrada: Hoky

Solo estoy tomando una pequeña porción de datos por simplicidad. MI objetivo es copiar los datos de la Hoja de datos, en función del filtro. Tengo una macro que de alguna manera funciona pero está codificada y es una macro grabada.

Mis problemas son:

1. El número de filas es diferente cada vez. (esfuerzo manual)
2. Las columnas no están en orden.

Sub TESTTHIS()
''
'' TESTTHIS Macro
''
''FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"

''Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste

Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste

Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste

End Sub

Answer 1

Cuando necesito copiar datos de una tabla filtrada, uso range.SpecialCells (xlCellTypeVisible) .copy. Donde el rango es el rango de todos los datos (sin filtro).

Ejemplo:

Sub copy()
     ''source worksheet
     dim ws as Worksheet
     set ws = Application.Worksheets("Data")'' set you source worksheet here
     dim data_end_row_number as Integer
     data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
    ''enable filter
    ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
    ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
    Application.Worksheets("Hoky").Range("B3").Paste
    ''You have to add headers to Hoky worksheet
end sub

Answer 2

Te sugiero que lo hagas de una manera diferente.

En el siguiente código configuré como Range la columna con el nombre deportivo F y recorro cada celda del mismo, verifico si es "hockey" y, en caso afirmativo, inserto los valores en la otra hoja uno por uno, usando Offset .

No creo que sea muy complicado e incluso si solo está aprendiendo VBA, probablemente debería ser capaz de comprender cada paso. Avísame si necesitas alguna aclaración

Sub TestThat()

''Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long

''Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")

Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
    ''I went from the cell row3/column6 (or F3) and go down until the last non empty cell

    i = 2

    For Each rCell In SportsRange ''loop through each cell in the range

        If rCell = "hockey" Then ''check if the cell is equal to "hockey"

            i = i + 1                                ''Row number (+1 everytime I found another "hockey")
            HokySh.Cells(i, 2) = i - 2               ''S No.
            HokySh.Cells(i, 3) = rCell.Offset(0, -1) ''School
            HokySh.Cells(i, 4) = rCell.Offset(0, -2) ''Background
            HokySh.Cells(i, 5) = rCell.Offset(0, -3) ''Age

        End If

    Next rCell

End Sub

Answer 3

La mejor manera de hacerlo.

El siguiente código es copiar los datos visibles en la hoja DBExtract y pegarlos en la hoja de registros duplicados, con solo valores filtrados. El rango seleccionado por mí es el rango máximo que pueden ocupar mis datos. Puede cambiarlo según su necesidad.

  Sub selectVisibleRange()

    Dim DbExtract, DuplicateRecords As Worksheet
    Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
    Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")

    DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
    DuplicateRecords.Cells(1, 1).PasteSpecial


    End Sub