' 本例来自论坛提问，因为写好这个代码时，该贴已结，所以放到这儿做个备忘
     ' 问题如下：

     ' EXCEL内容如下：
     '        A列
     ' 1  【题　名】论树立科学发展观，提升企业技术创新能力
     ' 2  【作 者】黄海
     ' 3  【机 构】不详
     ' 4  【刊　名】交通世界.2006(10B).-78-79
     ' 5
     ' 6
     ' 7
     ' 8
     ' 9  【题 名】畜牧业发展与科学技术
     ' 10 【作 者】段诚中
     ' 11 【机 构】四川省畜牧科学研究院研究员
     ' 12 【刊　名】农村养殖技术.2006(18).-5-5
     ' 13
     ' 14
     ' 15
     ' 16
     ' 17 【题　名】加快技术创新步伐 振兴纺织机械制造业
     ' 18 【作 者】无
     ' 19 【机 构】中国纺织机械器材工业协会, 100742
     ' 20 【刊　名】纺织机械.2006(5).-2-9

     ' 如上所写 , 在A列中, 有2000多个这样的格式数据
     ' 现在的目的是想把A列数据通过vba或函数,提取数据成为按列拆分.

     ' b                        c         d                            e
     ' 题名                     作者      机构                         刊名
     ' 论树立科学...            黄海      不详                         交通世界.2006(10B).-78-79
     ' 畜牧业发展与科学技术     段诚中    四川省畜牧科学研究院研究员   农村养殖技术.2006(18).-5-5
    
     ' 各位大哥怎么实现.跪地求,项目紧!!

  ' excel对象
     Dim  oExcel  As   Object
     Dim  oBook  As   Object
     Dim  oSheet  As   Object
     Dim  oRange  As   Object

     Dim  arrGet  As  Variant     ' 读出EXCEL的数组
     Dim  arrPut  As  Variant     ' 写入EXCEL的数组
     Dim  LastRow  As   Integer     ' 最后一行
     Dim  r  As   Integer , c  As   Integer
     Dim  row  As   Integer
    
On   Error   GoTo  App_Err:

     Set  oExcel  =   CreateObject ( " Excel.Application " )
     Set  oBook  =  oExcel.Workbooks.Open( " C: est.xls " )
     Set  oSheet  =  oBook.Worksheets( 1 )
    oSheet.Activate
    
     ' 确定最后一行
     Const  xlCellTypeLastCell  =   11
     Set  oRange  =  oSheet.UsedRange
    oRange.SpecialCells(xlCellTypeLastCell).Activate
    LastRow  =  oExcel.ActiveCell.row  +   4
     ' 将内容读入数组
     ReDim  arrGet( 1   To  LastRow,  1 )
    arrGet  =  oSheet.Range( " A1 " ).Resize(LastRow,  1 )
     ' 拆分内容，并将内容读入另一数组
     ReDim  arrPut( 1   To  LastRow  /   8   +   1 ,  1   To   4 )
    arrPut( 1 ,  1 )  =   " 题名 "
    arrPut( 1 ,  2 )  =   " 作者 "
    arrPut( 1 ,  3 )  =   " 机构 "
    arrPut( 1 ,  4 )  =   " 刊名 "
    row  =   2
     For  r  =   1   To  LastRow  Step   8
         For  c  =   0   To   3
            arrPut(row, c  +   1 )  =   Split (arrGet(r  +  c,  1 ),  " 】 " )( 1 )
         Next  c
        row  =  row  +   1
     Next  r
     ' 写入表格
    oSheet.Range( " B1 " ).Resize(LastRow  /   8   +   1 ,  4 ).Value  =  arrPut
    oBook.Save
    
     MsgBox   " ok "
    oBook.Close
App_Exit:
     Set  oSheet  =   Nothing
     Set  oBook  =   Nothing
    oExcel.Quit
     Set  oExcel  =   Nothing
     Exit Sub
App_Err:
     MsgBox  Err.Description
     Resume  App_Exit

End Sub