使用宏创建单独的Excel

Question

我有一个专栏，有一栏有关于招标的信息。每个单元格都有一个像

这样的值

专栏：诺基亚（[Mode1.Number]，OLD）

专栏：摩托罗拉（[Mode1.Number]，OLD）

专栏：摩托罗拉（[Mode2.Number]，NEW）

专栏：摩托罗拉（[Mode3.Number]，OLD）

专栏：三星（[Mode2.Number]，NEW）

我需要创建2个excel。一个人应该拥有OLD的所有信息，第二个excel应该拥有NEW的所有信息。

所以我的输出excel应该包含

第一个Excel

诺基亚（[Model1.Number]）

摩托罗拉（[Mode1.Number]）

摩托罗拉（[Mode3.Number]）

第二个Excel

摩托罗拉（[Mode2.Number]）

三星（[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