从POWERDESIGNER中生成需求列表（RQM）到EXCEL并分组

Option Explicit
   Dim noClass
   noClass = 0
   
'-----------------------------------------------------------------------------
' Main function
'-----------------------------------------------------------------------------

' Get the current active model
Dim Model
Set Model = ActiveModel
If (Model Is Nothing) Or (Not Model.IsKindOf(PdRQM.cls_Model)) Then
   MsgBox "The current model is not an RQM model."
Else
   ' Get the Classes collection
  
   '创建EXCEL APP
 DIM EXCEL, SHEET
 set EXCEL = CREATEOBJECT("Excel.Application")


EXCEL.workbooks.add(-4167)'添加工作表
EXCEL.workbooks(1).sheets(1).name ="test"
set sheet = EXCEL.workbooks(1).sheets("test")
 
ShowProperties Model, SHEET
EXCEL.visible = true
'sheet.range("A1:A" + noclass + 1).rows.Height = 15
End If


'-----------------------------------------------------------------------------
' Show properties of classes
'-----------------------------------------------------------------------------
Sub ShowProperties(package, sheet)
   ' Show classes of the current model/package
  noclass=0
   ' For each class
   output "begin"
   Dim cls
   For Each cls In package.Requirements
      ShowClass cls,sheet
   Next
   
   output "end"
   ' Show classes in the sub-packages
   Dim subpackage
   For Each subpackage In package.Packages
      If Not subpackage.IsShortcut Then
         ShowProperties subpackage
      ElseIf Not subpackage.External Then
         ' Accept internal shortcut of packages
         ShowProperties subpackage
      End If
   Next
   
End Sub

'-----------------------------------------------------------------------------
' Show class properties
'-----------------------------------------------------------------------------
Sub ShowClass(cls, sheet)
   If IsObject(cls) Then
   
     dim beginrow
     
     noclass = noclass + 1
     beginrow = noclass
      ' Show properties
      Output "================================"
      Output "================================"

      sheet.cells(noclass, 1) = cls.TitleIDText
      sheet.cells(noclass, 2) = cls.code
      sheet.cells(noclass, 3) = cls.Name
      'sheet.cells(noclass, 4) = cls.FullDescription
      sheet.cells(noclass, 5) = cls.Type
      sheet.cells(noclass, 6) = cls.Priority
      sheet.cells(noclass, 7) = cls.Status
      sheet.cells(noclass, 8) = cls.Risk
      
      Output "FullDescription: "       + cls.Name
      
      Dim cls1
      For Each cls1 In cls.Requirements
         ShowClass cls1,sheet
      Next
      
      if cls.Requirements.count > 0 then
        sheet.Range("A" & beginrow + 1 & ":A" & noclass).Rows.Group
      end if
         
   End If
End Sub