VBA : Find a string in Sheet1/ColA, move that whole row to Sheet2 (with a loop to do a large amount at once)

[ExcelJohn]

Hi Excel Users!

I have a UserForm with a TextBox and two buttons.

You insert a text string in the textbox, click the button, and this is what it does :

It finds the string in the A column of Sheet1.
It copies the whole row containing the matched string from Sheet1 to Sheet2.
It deletes the whole row from Sheet1.

Result : Cut from Sheet1 and paste to Sheet2
See the code at the end of the post.

I would like to know how to adapt that code to use a multiline TextBox, so I can do the same procedure for a large amount of strings (one per line). I know how to tweak the properties of the textbox to make it multiline, but I don't know how to turn the code into a loop that does the same, one by one, to all of them. I am going to paste a large amount of strings (~500) so it has to be ready for that.

Private Sub CommandButton1_Click()
    Dim myString As String
    Dim foundCell As Range
    
    myString = Trim(UserForm2.TextBox1.Value)
    If myString = vbNullString Then
        Exit Sub
    End If
    
    On Error GoTo ErrorOut
    
        ' Find and copy entire row.
        With Sheets("Sheet1").Range("A:A")
            Set foundCell = .Find(What:=myString, After:=.Cells(1, 1), LookAt:=xlWhole)
            foundCell.EntireRow.Copy
        End With
    
        ' Paste copied cell.
        Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
    
        ' Delete entire row of found range.
        foundCell.EntireRow.Delete
        
        UserForm2.Label2.Caption = "Record " & myString & " moved from Sheet1 to Sheet2"
        Exit Sub
        
ErrorOut:
    UserForm2.Label2.Caption = "Record " & myString & " doesn't exist in Sheet1 col A"
    On Error GoTo 0
End Sub

I would be very gald if someone could give me a hand.

Thanks!

 

[taurean]

It appears that you are matching the whole string. In that case you can loop it simply like:

Dim lLR as Long
lLR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
With Sheet1
For i = lLR to 1 Step -1
If .Range("A" & i).Value2 = myString Then
.Rows(i).Cut
ActiveSheet.Paste Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp)(2)
Application.CutCopyMode = False
.Rows(i).Delete
End If
Next i
End With

Caution: Untested so test it on a backup

 

[ExcelJohn]

It appears that you are matching the whole string. In that case you can loop it simply like:

Dim lLR as Long
lLR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
With Sheet1
For i = lLR to 1 Step -1
If .Range("A" & i).Value2 = myString Then
.Rows(i).Cut
ActiveSheet.Paste Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp)(2)
Application.CutCopyMode = False
.Rows(i).Delete
End If
Next i
End With

Caution: Untested so test it on a backup

Thanks taurean!

However I would like to adapt the code, not to change it. This is because it took a lot of time and posts to tweak it correctly and I am afraid if I change it, even if it's to an equivalent one, it won't work in all scenarios.

Wouldn't it be possible to just wrap the existing code in a loop ? The ammount of interations will be the ammount of lines in the TextBox and the string to be searched will be each line, one after one, of the TextBox.

I just don't know how to do that.

Thanks!!

 

[taurean]

In case if you want to stick with your original method then test the following code (have backup handy). I have tried to comment it for your reference:

Private Sub CommandButton1_Click()
    Dim myString As String
    Dim foundCell As Range, foundCell1 As Range
    
    myString = Trim(UserForm2.TextBox1.Value)
    If myString = vbNullString Then
        Exit Sub
    End If
    
    On Error GoTo ErrorOut
    
        
        With Sheets("Sheet1").Range("A:A")
        ' Find Cell with the given match
        Set foundCell = .Find(What:=myString, After:=.Cells(1, 1), LookAt:=xlWhole)
        
        'Loop for going through the Excel Column
        Do While Not foundCell Is Nothing
        
        'Copy the Entire Row
        foundCell.EntireRow.Copy
            
        ' Paste copied cell.
        Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
        
        'Find the next cell match
        Set foundCell1 = .FindNext(foundCell)
        
        ' Delete entire row of found range.
        foundCell.EntireRow.Delete
        
        'Pass it back to the original variable
        Set foundCell = foundCell1
        
        UserForm2.Label2.Caption = "Record " & myString & " moved from Sheet1 to Sheet2"
        Loop
        End With
    Exit Sub
ErrorOut:
    UserForm2.Label2.Caption = "Record " & myString & " doesn't exist in Sheet1 col A"
    On Error GoTo 0
End Sub

 

[MickG]

Try this:-
Enter data seperated by a Space.
You will need to alter some of the Control names back to there original !!!

Private [COLOR="Navy"]Sub[/COLOR] CommandButton1_Click()
    [COLOR="Navy"]Dim[/COLOR] myString [COLOR="Navy"]As[/COLOR] Variant
    [COLOR="Navy"]Dim[/COLOR] foundCell [COLOR="Navy"]As[/COLOR] Range, t
    [COLOR="Navy"]Dim[/COLOR] Pst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
    
    myString = Split(Trim(Me.TextBox1.Value), Chr(32))
    
    [COLOR="Navy"]For[/COLOR] Pst = 0 To UBound(myString)
      [COLOR="Navy"]If[/COLOR] myString(Pst) = vbNullString [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
    [COLOR="Navy"]End[/COLOR] If
    
    [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] GoTo ErrorOut
    
        '[COLOR="Green"][B] Find and copy entire row.[/B][/COLOR]
        [COLOR="Navy"]With[/COLOR] Sheets("Sheet10").Range("A:A")
            [COLOR="Navy"]Set[/COLOR] foundCell = .Find(What:=myString(Pst), After:=.Cells(1, 1), LookAt:=xlWhole)
            '[COLOR="Green"][B]MsgBox foundCell.Address[/B][/COLOR]
            foundCell.EntireRow.Copy
        [COLOR="Navy"]End[/COLOR] With
    
        '[COLOR="Green"][B] Paste copied cell.[/B][/COLOR]
        Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
    
        '[COLOR="Green"][B] Delete entire row of found range.[/B][/COLOR]
        foundCell.EntireRow.Delete
        
        Me.Label1.Caption = "Record " & myString(Pst) & " moved from Sheet1 to Sheet2"
        [COLOR="Navy"]Next[/COLOR] Pst
        [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
        
ErrorOut:
    Me.Label1.Caption = "Record " & myString(Pst) & " doesn'[COLOR="Green"][B]t exist in Sheet1 col A"[/B][/COLOR]
    [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] GoTo 0
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[ExcelJohn]

Thanks Mick, this works perfectly BUT I would like it to be a multiline TextBox, not a single line textbox.

That is, the user will enter in a big multiline TextBox around 500 entries like this :

FGHJ523#09
TMBP342#22
UIBD123##1
PSQW934#33
etc...

And not like this :
FGHJ523#09 TMBP342#22 UIBD123##1 PSQW934#33

How would I do it ?

Thanks!

 

[ExcelJohn]

Sorry I forgot to say one thing :

If any of the entries is not found, it displays the error message and stops processing the following ones.

Is there a simple way to avoid that ?

 

[Comfy]

myString = Split(Replace(Me.TextBox1.Value, vbCrLf, " "), " ")

 

[ExcelJohn]

Thanks Comfy, this works!!!

How many rows do you think this code will support ? I am expecting the user entrying batches of ~500-1000 entries at the same time.

 

[MickG]

I found using a textbox has a few problems.
This method basically works.
If you make the textbox the width of a single entry and make it multiline and each entry is seperated by a space, then the entries will show as a column of data, which is what you want.

If you enter the data single then press "Ctrl + Return" to place the entries in a column, then the data "Seperator" appears to be a space "Chr(32)" and a Return "Chr(13)" , you then have the problem of removing/splitting them to get a match with your data , which sound easier than it is !!

How do you intend to load your data, perhaps you have a better method ????