Find value and copy row to another sheet

[AggyRJ]

I have a workbook with 15 different sheets. The one has a compilation of all of the data (Sheet "SM1") and the rest need the data moved to them from SM1 based on values from SM1, column D. Column D is a a four digit numerical value (for instance the first value in cell D4 is 0111). The rest of the sheets are the numerical values (so sheet 2 is named 0111). I need a marco that will search column D in sheet SM1 for a value, and if a cell in the column matches the value then it moves the entire row to the first empty row in another sheet. I am trying to make this as clear as possible so at the risk of possibly being redundant let me give this example. In sheet "SM1" in cell D4 the value is 0111. I need the macro to search column D, find that D4 matches 0111, cuts the entire row that D4 is in, and moves it to the first empty row in sheet 0111. I think that I know enough about macro's to be able to modify it for the other 13 values that I need. Any help would be greatly appreciated. Thank you.

 

[sijpie]

This should do the trick.
The sub checks if the sheetnumber exists and then creates sheet if required. Then copies the row accross
If you want to delete the row from the SM1 sheet then add

rIn.Offset(i, 0).EntireRow.delete

before i=i+1 in the code below

Option Explicit
'### This sub moves rows to (new) sheets ###
Sub MoveSections()


    Dim rOut As Range, rIn As Range, rInEnd As Range
    Dim i As Long, sSect As String
    Dim wsIn As Worksheet, wsOut As Worksheet
    
    Application.ScreenUpdating = False
    'stop screen flikker
    
    Set wsIn = Sheets("SM1")
    
    Set rIn = wsIn.Cells(4, 4)           '(D4)
    Do While rIn.Offset(i, 0).Value <> vbNullString
        Set wsOut = Nothing
        On Error Resume Next
        Set wsOut = Worksheets(Trim(rIn.Offset(i, 0).Value))
        On Error GoTo 0
        If wsOut Is Nothing Then
            'sheet doesn't exist
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Trim(rIn.Offset(i, 0).Value)
            Set wsOut = ActiveSheet
        End If
        
        Set rOut = wsOut.Cells(wsOut.Rows.Count, "D").End(xlUp).Offset(1, -3)
                'rOut is now set to the first empty row (measured from comun D), column A


                    ' copy the values across. This is done by setting the values _
                      of the range equal, which is way faster than copy paste
            rOut.EntireRow.Value = rIn.Offset(i, 0).EntireRow.Value
        i = i + 1
        
    Loop
    Application.ScreenUpdating = True
    
    Set rIn = Nothing
    Set wsIn = Nothing
    Set rOut = Nothing
    Set wsOut = Nothing
End Sub

Oh yes one more thing: I was assuming that all the rows in SM1 (from 4 down) need to be done.

 

[AggyRJ]

That is exactly what I needed. Thank you so much.