excel - una - macro para filtrar datos y pegar valores en otra hoja

Macro de Excel para copiar y pegar datos de una hoja de cálculo a otra hoja de cálculo

Question

Intento buscar un valor en una columna y copiar la fila de Sheet1 y crear una nueva hoja como MySheet y pegar esa fila en particular. Pero obtengo un error de tiempo de ejecución al pegar datos en MySheet. Cualquier sugerencia, por favor.

Entrada de datos Estoy intentando:

ID nombre precio unidades desc

1 ikura 10 4 buzón

2 prueba 11 14 xxxx

3 prueba 11 14 aaaa

4 prueba 11 14 buzón

 Sub SearchForString()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
''Start search in row 4
LSearchRow = 4
''Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
Worksheets.Add (After:=Worksheets(Worksheets.Count)).Name = "MySheet"
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
''If value in column E = "Mail Box", copy entire row to Sheet2
If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then
''Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
''Paste row into Sheet2 in next row
Sheets("MySheet").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
''Move counter to next row
LCopyToRow = LCopyToRow + 1
''Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
''Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub

Saludos,

Raju

Answer 1

Lo primero es lo primero:

• Deja de usar. Selecciona y .Activate cuando no sean necesarios, son los métodos del diablo. Trate directamente con los objetos de rango / hoja de trabajo.
• Cambie los contadores de fila de Intergers a longs por si acaso.
• Declarar explícitamente en qué hoja de trabajo está trabajando puede salvarse de extraños errores / errores. Si no te gusta la escritura, utiliza un objeto de hoja de cálculo.
• Su manejador de errores siempre debe generar err.Number y err.Description. Si lo hubiera hecho desde el principio, probablemente no habría tenido que publicar esta pregunta.
• Range.Copy tiene un argumento de destino. Úselo en lugar de Range.Paste para ahorrar algunos dolores de cabeza potenciales.

Aquí hay un código simplificado, mira si funciona:

Sub SearchForString()
Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim wksInput As Worksheet
Dim wksOutput As Worksheet
On Error GoTo Err_Execute
''Create a new sheet output to and store a reference to it
''in the wksOutput variable
Set wksOutput = Worksheets.Add(AFter:=Worksheets(Worksheets.Count))
wksOutput.Name = "MySheet"
''The wksInput variable will hold a reference to the worksheet
''that needs to be searched
Set wksInput = ThisWorkbook.Worksheets("Sheet2")
''Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
''Loop through all the rows that contain data in the worksheet
''Start search in row 4
For LSearchRow = 4 To wksInput.UsedRange.Rows.Count
''If value in column E = "Mail Box", copy entire row to wksOutput
If wksInput.Cells(LSearchRow, 5) = "Mail Box" Then
''One line copy/paste
wksInput.Rows(LSearchRow).Copy wksOutput.Cells(LCopyToRow, 1)
''Increment the output row
LCopyToRow = LCopyToRow + 1
End If
Next LSearchRow
With wksInput
.Activate
.Range("A3").Select
End With
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred. Number: " & Err.Number & " Description: " & Err.Description
End Sub

Answer 2

Prueba esta versión simplificada:

Sub CopyData()
''// Turn off screen updating for cosmetics
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MySheet"
''// Change this to your sheet you are copying from
With Sheet1
''// Filter all rows with Mail Box
.Range("E:E").AutoFilter Field:=1, Criteria1:="Mail Box", Operator:=xlAnd
''// Copy all rows except header
.UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Worksheets("MySheet").Cells(2, 1)
''// Remove the autofilter
If .AutoFilterMode Then .AutoFilterMode = False
End With
Application.ScreenUpdating = True
MsgBox "All matching data has been copied."
End Sub