How to make a button that just copies selected row on one sheet to another sheet by VBA ?

[Kenor]

I want to transfer data from one sheet to another sheet by enter row number in a text box and enter commandbutton by using VBA code.
Anyone can help me?

 

[Zot]

Please specify if your destination sheet is always the same sheet or any sheet. Do the range to transfer is column A to G?

 

[Kenor]

Please specify if your destination sheet is always the same sheet or any sheet. Do the range to transfer is column A to G?

Yes, the destination sheet is always the same sheet.
The range also same from column A to G.

 

[Zot]

Private Sub CommandButton1_Click()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")
Set cell = ActiveCell

ws1.Range("A" & cell.Row, "G" & cell.Row).Copy Destination:=ws2.Range("A" & cell.Row)

End Sub

 

[Kenor]

How to enter a row number every time I want to copy data?
My thinking actually to create one text box and one common button. So, that I can enter a row number in the text box and enter common button to copy the data to another sheet.

 

[Zot]

How to enter a row number every time I want to copy data?
My thinking actually to create one text box and one common button. So, that I can enter a row number in the text box and enter common button to copy the data to another sheet.

In my code you just select the row you want to copy and click button

I see, the problem would be what if the row is way down and your button is way up. Not convenient

 

[Kenor]

I was create one text box and common button (see the attached picture). But in the text box, let say I enter number 3, it will find the first address in each cell that have number 3 .

Please help to review below code and advise. What I can change ?

Public Sub search_text()

Dim My_Activesheet As Variant
Dim Last_Row As Long
Dim my_range As Range
Dim c As Variant
Dim firstaddress As Variant
Dim Last_Copied_Row As Long
Dim Records_Copied As Integer

'check if something to search for.
If Trim(ActiveSheet.TextBox1.Text) = "" Then
    MsgBox "Nothing to search for"
    Exit Sub
End If

Set My_Activesheet = ActiveSheet

'add results sheet.
On Error Resume Next
Worksheets("Results").Name = "Results"
If Err.Number = 9 Then
    Worksheets.Add After:=Sheets(Sheets.Count)
    Worksheets(Sheets.Count).Name = "Results"
    Worksheets("Results").Range("A1").Value = "Results"
End If
On Error GoTo 0

My_Activesheet.Activate

Last_Row = ActiveSheet.Range("A65536").End(xlUp).Row
If Last_Row = 2 Then
    MsgBox ("No Rows of Data could be found to search")
    Exit Sub
End If

'exclude headers from used range
Set my_range = ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1)

'find data and copy
Records_Copied = 0
With my_range
    Set c = .Find(ActiveSheet.TextBox1.Value, LookIn:=xlValues, searchorder:=xlByRows)
    If Not c Is Nothing Then
        firstaddress = c.Address
        Last_Copied_Row = 0
        Do
            If Last_Copied_Row <> c.Row Then 'check to make sure row not already copied
                c.EntireRow.Copy Destination:=Worksheets("Results").Range("A" & Worksheets("Results").Range("A65536").End(xlUp).Row + 1)
                Records_Copied = Records_Copied + 1
                Last_Copied_Row = c.Row
            End If
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
End With

'display results
If Records_Copied = 0 Then
    MsgBox "No Search Results Found"
Else
    MsgBox "Copied over " & Records_Copied & " records to Results sheet"
End If

End Sub

 

[Zot]

Another option using ActiveX is to use TextBox.

You enter the line number and press Enter, the code run. To make this work you need to set EnterKeyBehavior to True (Default is False). If not nothing will happen whe pressing Enter

Use this code

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")

If KeyCode = vbKeyReturn Then
    If Not TextBox1.Text = "" Then
        ws1.Range("A" & TextBox1.Text, "G" & TextBox1.Text).Copy Destination:=ws2.Range("A" & TextBox1.Text)
        TextBox1.Text = ""
    End If
End If

 

[Zot]

I was create one text box and common button (see the attached picture). But in the text box, let say I enter number 3, it will find the first address in each cell that have number 3 .

Please help to review below code and advise. What I can change ?


Public Sub search_text()

Dim My_Activesheet As Variant
Dim Last_Row As Long
Dim my_range As Range
Dim c As Variant
Dim firstaddress As Variant
Dim Last_Copied_Row As Long
Dim Records_Copied As Integer

'check if something to search for.
If Trim(ActiveSheet.TextBox1.Text) = "" Then
MsgBox "Nothing to search for"
Exit Sub
End If

Set My_Activesheet = ActiveSheet

'add results sheet.
On Error Resume Next
Worksheets("Results").Name = "Results"
If Err.Number = 9 Then
Worksheets.Add After:=Sheets(Sheets.Count)
Worksheets(Sheets.Count).Name = "Results"
Worksheets("Results").Range("A1").Value = "Results"
End If
On Error GoTo 0

My_Activesheet.Activate

Last_Row = ActiveSheet.Range("A65536").End(xlUp).Row
If Last_Row = 2 Then
MsgBox ("No Rows of Data could be found to search")
Exit Sub
End If

'exclude headers from used range
Set my_range = ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1)

'find data and copy
Records_Copied = 0
With my_range
Set c = .Find(ActiveSheet.TextBox1.Value, LookIn:=xlValues, searchorder:=xlByRows)
If Not c Is Nothing Then
firstaddress = c.Address
Last_Copied_Row = 0
Do
If Last_Copied_Row <> c.Row Then 'check to make sure row not already copied
c.EntireRow.Copy Destination:=Worksheets("Results").Range("A" & Worksheets("Results").Range("A65536").End(xlUp).Row + 1)
Records_Copied = Records_Copied + 1
Last_Copied_Row = c.Row
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With

'display results
If Records_Copied = 0 Then
MsgBox "No Search Results Found"
Else
MsgBox "Copied over " & Records_Copied & " records to Results sheet"
End If

End Sub

You can capture Enter without need to use Command Button if you like using code I just posted

 

[Kenor]

W

Another option using ActiveX is to use TextBox.

You enter the line number and press Enter, the code run. To make this work you need to set EnterKeyBehavior to True (Default is False). If not nothing will happen whe pressing Enter

Use this code

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")

If KeyCode = vbKeyReturn Then
    If Not TextBox1.Text = "" Then
        ws1.Range("A" & TextBox1.Text, "G" & TextBox1.Text).Copy Destination:=ws2.Range("A" & TextBox1.Text)
        TextBox1.Text = ""
    End If
End If

Sorry...What meaning of this error? Do I need to change ?