Создание отдельного excel с использованием макроса

Question

У меня есть превосходство с одной колонкой, в которой есть информация о тендере. Каждая ячейка будет иметь значение как

Колонка: Nokia ([Mode1.Number], OLD)

Колонка: Motorola ([Mode1.Number], OLD)

Колонка: Motorola ([mode2. Number], NEW)

Колонка: Motorola ([Mode3.Number], OLD)

Колонка: Samsung ([Mode2.Number] NEW)

мне нужно создать 2 выделиться из этого , Нужно иметь всю информацию о OLD, а вторая excel должна иметь всю информацию NEW.

Так что мой выход первенствует должен содержать

Первый Excel

Nokia ([Model1.Number])

Motorola ([Mode1.Number])

Motorola ([Mode3.Number ])

Второй Excel

Motorola ([Mode2.Nu mber])

Samsung ([Mode2.Number])

Пожалуйста, помогите мне .. Спасибо заранее ..

Answer 1

Выделите ячейки, содержащие данные, которые вы хотите скопировать, а затем запустить этот код

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 

Answer 2

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