Find value and copy row to another sheet

AggyRJ

New Member
Joined
Mar 29, 2013
Messages
14
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.
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

sijpie

Well-known Member
Joined
Nov 1, 2008
Messages
3,734
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
Code:
rIn.Offset(i, 0).EntireRow.delete
before i=i+1 in the code below

Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,106
Messages
5,640,132
Members
417,126
Latest member
Jeffman52

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top