I am having a excel with one column that has got information regarding tender. Each cell will have a value like

Column: Nokia([Mode1.Number],OLD)

Column: Motorola([Mode1.Number],OLD)

Column开发者_Python百科: Motorola([Mode2.Number],NEW)

Column: Motorola([Mode3.Number],OLD)

Column: Samsung([Mode2.Number],NEW)

I need to create 2 excel out of this. One should 've all the information of the OLD and the second excel should've all the information of NEW.

So my output excel should contain

First Excel

Nokia([Model1.Number])

Motorola([Mode1.Number])

Motorola([Mode3.Number])

Second Excel

Motorola([Mode2.Number])

Samsung([Mode2.Number])

Kindly help me.. Thanks in advance..

Highlight the cells containing the data you want to copy and then run this code

sub copystuff
dim r as range
dim tn as range
im to as range
dim wsNewTarget as worksheet
dim wsOldTarget as worksheet
dim wsSource as worksheet
set wsSource = activesheet
set wsNewtarget = activeworkbook.worksheets.add
set wsoldtarget = activeworkbook.worksheets.add
set tn = wsnewtarget.range("a1")
set to =wsoldtarget.range("a1")
for each r in wssource.selection
    if imstr(r,"NEW")>0 then
          tn=r
           set tn = tn.offset(1,0)
    else
         to=r
           set to = to.offset(1,0)

     end if
next r
end sub

Sub SplitOldNew()
Dim InRange As Range, OldRange As Range, NewRange As Range
Dim Idx As Integer

    Set InRange = Selection                ' select all cells to be split
    Set OldRange = Worksheets("OLD").[A1]  ' choose appropriate target entry points
    Set NewRange = Worksheets("NEW").[A1]  ' ...
    Idx = 1                                ' loop counter

    Do While InRange(Idx, 1) <> ""
        If InStr(1, InRange(Idx, 1), "OLD") <> 0 Then
            DBInsert OldRange, InRange(Idx, 1)
        Else
            DBInsert NewRange, InRange(Idx, 1)
        End If
        Idx = Idx + 1
    Loop
End Sub

Sub DBInsert(intoRange As Range, Arg As String)
Dim Idx As Integer

    Idx = 1                                ' loop counter
    Do While intoRange(Idx, 1) <> ""       ' find first blank row
        Idx = Idx + 1
    Loop

    intoRange(Idx, 1) = Arg                ' write out
End Sub