How to copy data row form one sheet to anothe

Closed
Redsh0es - Mar 15, 2011 at 10:29 PM
RWomanizer Posts 365 Registration date Monday February 7, 2011 Status Contributor Last seen September 30, 2013 - Mar 16, 2011 at 07:23 AM
Hello,



Please help me how to copy one data row from one sheet to another. Here's the link of the screenshot:

http://fc02.deviantart.net/fs70/i/2011/074/d/a/excel_help_by_redsh0es-d3bqift.jpg


Now, I want to copy the data row from "DEFECTIVES" sheet to the corresponding sheets according to "Defective unit" (Column C)

If the Defective unit is Television, then all Television rows will go to Television sheet and so on..

I dont know how to start, im not sure if i will include buttons or what.

im not familiar in excel especially in macro codes... Please Please help me..

1 response

RWomanizer Posts 365 Registration date Monday February 7, 2011 Status Contributor Last seen September 30, 2013 120
Mar 16, 2011 at 07:23 AM
Open your workbook,
Press Alt + F11; the visual basic editor will be open paste below code there here;
save it:

To Run the code press Alt + F11 and press the play button on toolbar,

Sub DistributeRowsToNewWBS()
Dim wbNew As Worksheet
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
    
    Set wsData = Worksheets("Defectives") ' name of worksheet with the data
    Set wsCrit = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    ' column H has the criteria
    wsData.Range("C1:C" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    Set rngCrit = wsCrit.Range("A2")
    While rngCrit.Value <> ""
        Set wsNew = Worksheets.Add
        ' change E to reflect columns to copy
        wsData.Range("A1:E" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        wsNew.Name = rngCrit
        Application.DisplayAlerts = False
        rngCrit.EntireRow.Delete
        Set rngCrit = wsCrit.Range("A2")
    Wend
    
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub
0