'半夜里匆忙写成，第一次用VBA，只是实现功能，未做性能优化，有时间要重写一下。 Sub Fighting()Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseDim Cell As Range, FirstAddress As StringDim temp As LongDim c As LongDim tempValue As LongDim d As LongDim str As StringDim RowCount As LongDim tempRow As LongDim tempStr As StringDim struNo As LongDim commentRow As LongDim findRow As RangeDim excelApp, excelWB As ObjectDim savePath As String'机构号With Sheet1RowCount = LastRow()For c = 1 To RowCount    str = .Cells(c, 1).Value        If Len(str) > 0 Then       str = Mid(str, 5, 6)        .Cells(c, 2) = str    End If    NextEnd With'根据机构号，查询对应的行数,放在C列With Sheet1For c = 1 To RowCount    If .Cells(c, 2).Value > 0 Then            temp = .Cells(c, 2).Value                '查询行        With Sheet3            For Each Cell In .Range("A1:A131").Cells                If Cell.Value = temp Then                       tempValue = .Cells(Cell.Row, Cell.Column + 1).Value                End If            Next        End With                .Cells(c, 3) = tempValue    End If    NextEnd With'根据行数,生成新的工作表2With Sheet1tempRow = 1For c = 1 To RowCount    If .Cells(c, 3).Value > 0 Then            temp = .Cells(c, 3).Value       '行数        str = .Cells(c, 1).Value        '单号        struNo = .Cells(c, 2).Value     '机构号                '查询所在行        'Set findRow = Sheet4.Cells.Find(what:=struNo, LookIn:=xlValues)        commentRow = Sheet4.Cells.Find(what:=struNo, LookIn:=xlValues).Row                With Sheet2            For d = 1 To temp                            .Cells(tempRow, 1).NumberFormatLocal = "@"                .Cells(tempRow, 1).ShrinkToFit = True                .Cells(tempRow, 1).Value = str                            .Cells(tempRow, 2).Value = 0                .Cells(tempRow, 3).Value = d - 1                                '取特约内容                .Cells(tempRow, 4).Value = Sheet4.Cells(commentRow + d - 1, 3)                                tempRow = tempRow + 1            Next        End With    End IfNextEnd With'将结果输出到新文件    Set excelApp = CreateObject("Excel.Application")    Set excelWB = excelApp.Workbooks.Add    excelApp.DisplayAlerts = False    savePath = ActiveWorkbook.Path & "\SLBPS_学生险特约导入_2012-XX-XX.xls"    excelWB.SaveAs savePath    excelApp.Quit    Workbooks.Open savePath    '复制    Sheet2.Copy Before:=Workbooks("SLBPS_学生险特约导入_2012-XX-XX.xls").Sheets(1)    With Workbooks("SLBPS_学生险特约导入_2012-XX-XX.xls").Sheets(1)                Sheets(1).Name = "学生险特约"        Rows(1).Insert        Range("a1") = "CNTR_NO"        Range("b1") = "IPSN_NO"        Range("c1") = "SPE_NO"        Range("d1") = "SPE_DETAIL"                Columns(1).ColumnWidth = 25'保存    Workbooks("SLBPS_学生险特约导入_2012-XX-XX.xls").Close SaveChanges:=True    End With    '删除临时数据Sheet1.Columns(3).DeleteSheet1.Columns(2).DeleteSheet2.Columns(4).DeleteSheet2.Columns(3).DeleteSheet2.Columns(2).DeleteSheet2.Columns(1).Delete'更新UIApplication.ScreenUpdating = TrueMsgBox "宏命令执行完成， 文件生成成功!"End SubFunction LastRow() As Long    Dim ix As Long    ix = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count    LastRow = ixEnd Function