Button click, cut and paste into another spreadsheet data that was filtered

Hi.

I have a code to filter data by an ActiveX textbox.
works well, but need a adatção.

I would use a button that when clicked, the line would be filtered cut and pasted into another tab.


Big File in: http://www.sendspace.com/file/nis5zh

Private Sub TextBox1_LostFocus()
     FilterNow
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     If KeyCode = Asc(vbCr) Then
         FilterNow
         Range("A1").Select
     End If
End Sub
Private Sub FilterNow()
     If Trim(TextBox1.Value) > vbNullString Then
         Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:=TextBox1.Value
     ElseIf ActiveSheet.AutoFilterMode Then
         Range("A1").CurrentRegion.AutoFilter
     End If
End Sub

thank you!

Hi.

Any idea?

Thank you!!!

Hi.

lacked a description must be re-cut line, not copied
can you do this?
thank you!

Hi.
I tried using the 'Cut' but generated this error

Run-time error '1004 ':
The chosen command can not be performed with multiple selections.
Just select a range and click the command again.

There is another way to eliminate the row that was copied?

Hi.
generated this error

Runtime Error '9 ':
subscript out of range

Thank you!!!

Hi Marreco,

What should we name the Tab and is it in the same book?

Hi.

See file...
http://www.sendspace.com/file/s7j56g

Thank you!!

Hi Marreco,

I would use a button that when clicked, the line would be filtered cut and pasted into another tab.

There's no button on the new file ????

Hi.

I had the attachment problem and had to send a new one.

but would the tab button 'Devolução - Total & Parcial'

the code posted by: rylo ok, but I need the copied data is removed from the guide 'Devolução - Total & Parcial'

Hi Marreco,

Do you want the extractions all on the same sheet or do you want a sheet for each extraction - if you want the latter:

This code goes in a module:

Private Sub Button1033_Click(): Dim r As Long, ws As Worksheet
        Set ws = ActiveSheet
    FilterNow
    With ActiveSheet
    For r = 2 To .Range("A" & Rows.Count).End(xlUp).Row
    If Rows(r).Hidden = False Then
    Exit For
    End If: Next r
    End With
    On Error GoTo OnError
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = ws.Range("B" & r)
    ws.Range("A" & r).EntireRow.Cut ActiveSheet.Range("A1")
    ws.Range("A" & r).EntireRow.Delete Shift:=xlUp
OnError:
    ws.ShowAllData: ws.Activate
    ActiveSheet.TextBox1.Value = vbNullString
End Sub
Sub FilterNow()
    With ActiveSheet
        If Trim(.TextBox1.Value) > vbNullString Then
         .Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:=.TextBox1.Value
        ElseIf .AutoFilterMode Then
         .Range("A1").CurrentRegion.AutoFilter
        End If
        .Range("A1").Select
     End With
End Sub

And the other code stays in the sheet.

Hi.

In my example, will always be a filtered line, that line should be re-cut the sheet 'Devolução - Total & Parcial' to the worksheet 'Sheet1'

Hi Marreco,

You just want one tab - do you want to put more than one "cutting" on it?

Just remove the naming part from the code I sent you:

From this:

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = ws.Range("B" & r)

To this:

Worksheets.Add(After:=Worksheets(Worksheets.Count))

Hi.

It turns out that your code is not sending the finger to another tab

Thank you!!!

Hi,

Which book did you use? My code works on the first one????????

Hi.

Private Sub TextBox1_LostFocus()
     FilterNow
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     If KeyCode = Asc(vbCr) Then
         FilterNow
         Range("A1").Select
     End If
End Sub
Private Sub FilterNow()
     If Trim(TextBox1.Value) > vbNullString Then
         Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:=TextBox1.Value
     ElseIf ActiveSheet.AutoFilterMode Then
         Range("A1").CurrentRegion.AutoFilter
     End If
End Sub

When you enter the code in ActiveX Textbox.
A line will be filtered in the worksheet 'Devolução - Total & Parcial' I need a code that after filtering the line is re-cut to the worksheet 'Sheet1'

Hi Marreco,

Try this (all in the source sheet)

Private Sub ButtonGone(): Dim r As Long, i As Long
    If ActiveCell.Row = 1 Then Exit Sub
    Do: i = i + 1: Loop Until Worksheets("Sheet1").Range("A" & i) = ""
   With ActiveSheet
    For r = 2 To .Range("A" & Rows.Count).End(xlUp).Row
    If Rows(r).Hidden = False Then
    Exit For
    End If: Next r
    On Error GoTo OnError
    Range("A" & r).EntireRow.Cut Worksheets("Sheet1").Range("A" & i)
    Range("A" & r).EntireRow.Delete Shift:=xlUp: i = i + 1
    End With
OnError:
    With ActiveSheet
    ShowAllData
    ActiveSheet.TextBox1.Value = vbNullString
    End With
End Sub
Private Sub TextBox1_LostFocus()
     FilterNow
     ButtonGone
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     If KeyCode = Asc(vbCr) Then
         FilterNow
         ButtonGone
     End If
End Sub
Private Sub FilterNow()
     If Trim(TextBox1.Value) > vbNullString Then
         Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:=TextBox1.Value
     ElseIf ActiveSheet.AutoFilterMode Then
         Range("A1").CurrentRegion.AutoFilter
     Else: Range("A1").Select
     End If
End Sub
Sub TestFilter()
Range("D17").Activate
End Sub

Hi,
Textbox while typing in the number '600150560 'the row that number has to go to another worksheet.
If I click there goes correctly, is correct?


When I press the 'Enter' key, which is another number that goes to another worksheet.
Another thing, the data must stay one beneath the other, if I filter another number the old data from Sheet1 disappears, and again sits atop the old.

Try it again - I just re-edited the last post!

Hi.
When running is giving the following error:

Runtime Error '9 ':
Subscript form interval

This line

Do: i = i + 1:

Thank you!!

Hi..


When running is giving the following error:
Runtime Error '9 ':
Subscript form interval
This line

Do: i = i + 1:
Thank you!!

Hi.
I had to change so now is the way I need.

Private Sub TextBox1_LostFocus()
     FilterNow
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     If KeyCode = Asc(vbCr) Then
         FilterNow
     End If
End Sub
Private Sub FilterNow()
     If Trim(TextBox1.Value) > vbNullString Then
         Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:=TextBox1.Value
     ElseIf ActiveSheet.AutoFilterMode Then
         Range("A1").CurrentRegion.AutoFilter
     Else: Range("A1").Select
     End If
End Sub

Sub TestFilter()
    Application.DisplayAlerts = False
    Range("A2:Q" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Plan1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Range("A2:Q" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
End Sub

How do I put a msgbox if the users decide not enviaar the data to another tab?
See what I tried but it did not work!

Sub TestFilter()
    Dim iRet As Integer
    MsgBox "Favor conferir o número da ordem!" & "-" & Me.TextBox1.Value, vbOKCancel, "Atenção...!"
    If iRet = OK Then
    Application.DisplayAlerts = False
    Range("A2:Q" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Plan1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Range("A2:Q" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
    Else
    Exit Sub
    End If
End Sub

Thank you!!

Hi.

I'm try this

Sub TestFilter()
If MsgBox("Favor conferir o número da ordem!" & "-" & Me.TextBox1.Value, vbOKCancel, "Atenção...!") = vbOK Then
    Application.DisplayAlerts = False
    Range("A2:Q" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Plan1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Range("A2:Q" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
    Plan1.ShowAllData
    Else
    Plan1.ShowAllData
    Exit Sub
    End If
End Sub

But....

Compile error:
Invalid use of the word Key, Me

Hi.

If I remove "Me.TextBox1.Value" the code works.

Otherwise generates the error!

Thaks for all!!!

Hi Marreco,

I guess you've got it solved - but, this works nicely - I replaced the Lost Focus with a Change event and now you need to hit the enter button for it to trigger:

Private Sub ButtonGone(): Dim r As Long, i As Long
    If ActiveCell.Row = 1 Then Exit Sub
    Do: i = i + 1: Loop Until Worksheets("Sheet1").Range("A" & i) = ""
   With ActiveSheet
    For r = 2 To .Range("A" & Rows.Count).End(xlUp).Row
    If Rows(r).Hidden = False Then
    Exit For
    End If: Next r
    On Error Resume Next
    Range("A" & r).EntireRow.Cut Worksheets("Sheet1").Range("A" & i)
    Range("A" & r).EntireRow.Delete Shift:=xlUp
    End With
    With ActiveSheet
    ShowAllData
    ActiveSheet.TextBox1.Value = vbNullString
    End With
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     If KeyCode = Asc(vbCr) Then
         FilterNow
         ButtonGone
     End If
End Sub
Private Sub FilterNow()
     If Trim(TextBox1.Value) > vbNullString Then
         Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:=TextBox1.Value
     ElseIf ActiveSheet.AutoFilterMode Then
         Range("A1").CurrentRegion.AutoFilter
     Else:
     ActiveSheet.Range("A1").Select
     End If
End Sub
Sub TestFilter(): Range("D13").Activate: End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 4 And Target.Row > 1 Then
ActiveSheet.TextBox1.Value = Target.Value
Me.TextBox1.Activate
End If: End Sub