VBA 特约导入代码

'半夜里匆忙写成，第一次用VBA，只是实现功能，未做性能优化，有时间要重写一下。

Sub Fighting()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim Cell As Range, FirstAddress As String
Dim temp As Long
Dim c As Long
Dim tempValue As Long
Dim d As Long
Dim str As String
Dim RowCount As Long
Dim tempRow As Long
Dim tempStr As String
Dim struNo As Long
Dim commentRow As Long
Dim findRow As Range
Dim excelApp, excelWB As Object
Dim savePath As String


'机构号
With Sheet1
RowCount = 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
    
Next
End With



'根据机构号，查询对应的行数,放在C列
With Sheet1

For 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
    
Next
End With


'根据行数,生成新的工作表2
With Sheet1
tempRow = 1
For 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 If
Next
End 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).Delete
Sheet1.Columns(2).Delete
Sheet2.Columns(4).Delete
Sheet2.Columns(3).Delete
Sheet2.Columns(2).Delete
Sheet2.Columns(1).Delete


'更新UI
Application.ScreenUpdating = True

MsgBox "宏命令执行完成， 文件生成成功!"

End Sub

Function LastRow() As Long
    Dim ix As Long
    ix = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    LastRow = ix
End Function