lost macro to move rows to another sheet based on text string

[larrissag]

Hello! This forum has been sooo helpful, I was able to find and tweak code to move rows from Sheet1 to Sheet2, A7, based on certain text contained in Column A...but I lost the macro somehow, I didn't save it properly or it was imbedded in a file I didn't save, something. Nonetheless, I'm back to square 1! I have SCOURED the forums for 2 whole days looking for the original code but I can't find it. There are similar posts but nothing that quite works like the original code from member Norie. I've seen many many posts on this topic while searching, but everyone has a slightly different request, I've tried to modify to no avail. If Column A says

apple 1234
apple 1234
pear 5678
grape 9123
apple 4567

If Column A contains "1234" (part of the text) then move whole row to Sheet2, starting at A7. I plan to repeat the code to move row containing text "5678" to sheet3, starting at A7, move text "9123" to sheet4 starting at A7, etc, etc. (the sheets are already formatted with headers and such, that's why the A7).

Can anyone bail me out, I'm dying here....

 

[vcoolio]

Hello Larrissa,

In relation to your post #5, no, that is something you won't have to do.
I'll be back. I just have to disappear for a while.

Cheerio,
vcoolio.

 

[vcoolio]

Hello Larrissa,

I've taken this one step further than you actually asked for thinking that it just may be a better option for you.
The following code takes each individual customer's details (account name and number) from Column A of your input sheet (Sheet1) and creates a new sheet for each individual. It then transfers all the rows of relevant data for each individual into the individual's worksheet.

Sub LarrissaTest()

        Dim sht As Worksheet, ws As Worksheet, lr As Long, i As Long
        Dim CustID As Object, key As Variant
    
        Set sht = Sheet1
        Set CustID = CreateObject("Scripting.Dictionary")
        lr = sht.Range("A" & Rows.Count).End(xlUp).Row
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False
        
        For i = 2 To lr
              If Not CustID.Exists(sht.Range("A" & i).Value) Then
              CustID.Add sht.Range("A" & i).Value, 1
              End If
        Next i
        
        For Each key In CustID.keys
              If Not Evaluate("ISREF('" & CStr(key) & "'!A1)") Then
              Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
        End If
        
        Set ws = Sheets(CStr(key))
        ws.UsedRange.Clear
        
        With sht.Range("A1:A" & lr)
              .AutoFilter 1, key
              .Resize(, 9).Copy ws.[A7]
              .AutoFilter
        End With
        ws.Columns.AutoFit
        Next key

sht.Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

Each time that the code is run, it will refresh all details of all customers so each individual sheet is up to date. So, if you alter any details for a customer, their details will be updated. If you add a new customer to Column A, the same will happen with a new sheet created with all the relevant data.
I've attached a mock-up workbook for you to test with here. Click on the "RUN" button to see how it works.

Please note that in the sample, the Columns used are A:I (this is easily altered to suit in the code).The data in sheet1 starts in row2 with headings in row1.
Please also note that the maximum character limit for worksheet names is 31. Characters include spaces, underscores etc..

To see if this method suits, create a copy of your actual workbook and delete all the destination sheets. Leave sheet1 (your input sheet). Test the code in your copy.

I hope that this helps.

Cheerio,
vcoolio.

 

[larrissag]

@larrissag With 37 sheets, the following code is probably better for you:

'
Public SearchString         As String
'
Public DestinationSheet     As Worksheet
Public SourceSheet          As Worksheet
'
'

Sub MoveRowsFromOneSheetToAnotherDependentUponCellDataV2()
'
    Set SourceSheet = Sheets(1)                                     ' <-- Set Sheet Index Number OR Sheet Name inside the parentheses
'
'
    Set DestinationSheet = Sheets(2)                                ' <-- Set Sheet Index Number OR Sheet Name inside the parentheses
    SearchString = "*1234*"                                         ' <-- Edit the values here to what you are looking for
    Call SearchingSub
'
    Set DestinationSheet = Sheets(3)                                ' <-- Set Sheet Index Number OR Sheet Name inside the parentheses
    SearchString = "*5678*"                                         ' <-- Edit the values here to what you are looking for
    Call SearchingSub
'
    Set DestinationSheet = Sheets(4)                                ' <-- Set Sheet Index Number OR Sheet Name inside the parentheses
    SearchString = "*9123*"                                         ' <-- Edit the values here to what you are looking for
    Call SearchingSub
'
    Set DestinationSheet = Sheets(5)                                ' <-- Set Sheet Index Number OR Sheet Name inside the parentheses
    SearchString = "*4567*"                                         ' <-- Edit the values here to what you are looking for
    Call SearchingSub
'
'   ETC ...
'
End Sub

Sub SearchingSub()
'
    Dim LastRowInColumn             As Long
    Dim NextRowInDestinationSheet   As Long
    Dim RowCount                    As Long
'
    NextRowInDestinationSheet = 7                                   ' Starting row to copy matching rows to in the Destination sheet
'
    With SourceSheet
        LastRowInColumn = .Range("A" & Rows.Count).End(xlUp).Row    ' Find last used row in the search column
'
        For RowCount = 1 To LastRowInColumn                                                     ' Loop to check each cell in the search column
            If .Range("A" & RowCount) Like SearchString Then                                    '   check cell to see if it contains text we are looking for
                .Rows(RowCount).Copy DestinationSheet.Range("A" & NextRowInDestinationSheet)   '       If it does, copy the entire row to the Destination sheet
                NextRowInDestinationSheet = NextRowInDestinationSheet + 1                       '       Also Increment the next row to be copied to
            End If                                                                              '   End check of this cell
        Next RowCount                                                                           ' Loop back until all used cells in search column are checked
    End With
End Sub

That will get you started and you can just copy/paste more to handle all of your sheets that you may need. Just copy/paste and edit the sheet name/index number and the search string.

@johnnyL THIS WORKED! I'm so thrilled thank you for your expertise. I have a little more housecleaning to add to the end for overall formatting and figure out if the xldown is going to work, but this is great!

 

[larrissag]

Hello Larrissa,

I've taken this one step further than you actually asked for thinking that it just may be a better option for you.
The following code takes each individual customer's details (account name and number) from Column A of your input sheet (Sheet1) and creates a new sheet for each individual. It then transfers all the rows of relevant data for each individual into the individual's worksheet.

Sub LarrissaTest()

        Dim sht As Worksheet, ws As Worksheet, lr As Long, i As Long
        Dim CustID As Object, key As Variant
   
        Set sht = Sheet1
        Set CustID = CreateObject("Scripting.Dictionary")
        lr = sht.Range("A" & Rows.Count).End(xlUp).Row
   
Application.ScreenUpdating = False
Application.DisplayAlerts = False
       
        For i = 2 To lr
              If Not CustID.Exists(sht.Range("A" & i).Value) Then
              CustID.Add sht.Range("A" & i).Value, 1
              End If
        Next i
       
        For Each key In CustID.keys
              If Not Evaluate("ISREF('" & CStr(key) & "'!A1)") Then
              Worksheets.Add(After:=Sheets(Sheets.Count)).Name = key
        End If
       
        Set ws = Sheets(CStr(key))
        ws.UsedRange.Clear
       
        With sht.Range("A1:A" & lr)
              .AutoFilter 1, key
              .Resize(, 9).Copy ws.[A7]
              .AutoFilter
        End With
        ws.Columns.AutoFit
        Next key

sht.Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

Each time that the code is run, it will refresh all details of all customers so each individual sheet is up to date. So, if you alter any details for a customer, their details will be updated. If you add a new customer to Column A, the same will happen with a new sheet created with all the relevant data.
I've attached a mock-up workbook for you to test with here. Click on the "RUN" button to see how it works.

Please note that in the sample, the Columns used are A:I (this is easily altered to suit in the code).The data in sheet1 starts in row2 with headings in row1.
Please also note that the maximum character limit for worksheet names is 31. Characters include spaces, underscores etc..

To see if this method suits, create a copy of your actual workbook and delete all the destination sheets. Leave sheet1 (your input sheet). Test the code in your copy.

I hope that this helps.

Cheerio,
vcoolio.

@vcoolio this code is great too! Thank you for the example. You gave me a great idea for an application I didn't even know I needed! I'm going to make some notes and try applying this to my payroll worksheets. The result is going to be mind-blowingly awesome thanks to you!

 

[vcoolio]

You're welcome Larrissa. Glad to have been able to assist in some way and thanks for the feed-back.

Cheerio,
vcoolio.