QTP对EXCEL中的数据的统计

假设保存数据的EXCEL文件名为Book1.xls，则运行下面代码即可完成你所需要的统计工作：

Option Explicit
Private Sub Command1_Click()
Dim S As String, i As Long, j As Long, k As Long, js As Long
Dim rows As Long, cols As Long
Dim xlApp
Dim xlBook
Dim xlSheet, xlSheet1
Dim FileName As String, ExitComment As Boolean
Dim CountSheets As Integer, JobName As String

    FileName = App.Path & "\Book1.xls"    '****请根据实际进行修改****

    '下面代码为通用代码，请不要修改！
    Set xlApp = CreateObject("Excel.Application")    '创建EXCEL对象
    xlApp.DisplayAlerts = False    '不显示对话框
    Set xlBook = xlApp.Workbooks.open(FileName)    '打开已经存在的EXCEL工件簿文件
    xlApp.Visible = false    '设置EXCEL对象可见（或不可见）


    '当前最大页数
    CountSheets = xlBook.Worksheets.Count

    Set xlSheet = xlBook.Worksheets(1)    '设置活动工作表
    js = 0
    For i = 10 To 65536    '从第10行开始到excel最大
        If xlSheet.Range("K" & i).Value = "" Then Exit For    '如果遇到没有数值的单元格，退出循环
        JobName = xlSheet.Range("K" & i).Value    '小结名称

        '匹配是否已有该小结的页
        ExitComment = True
        For j = 2 To CountSheets
            If xlBook.Worksheets(j).Name = JobName Then
                Set xlSheet1 = xlBook.Worksheets(j)
                If xlSheet1.Range("A1").Comment Is Nothing Then ExitComment = False
                Exit For
            End If
        Next

        '如果不存在该小结的页，则创建一个新的页并命名
        If j = CountSheets + 1 Then
            xlBook.Worksheets.Add after:=xlBook.Worksheets(xlBook.Worksheets.Count)
            CountSheets = CountSheets + 1    '最大页数加1
            Set xlSheet1 = xlBook.Worksheets(xlBook.Worksheets.Count)
            xlSheet1.Name = JobName
            ExitComment = False
        End If
        xlSheet1.Select    '选择需要处理的页
        If ExitComment = False Then
            rows = xlSheet.UsedRange.rows.Count
            For k = rows To 10 Step -1 '删除旧数据
                xlSheet1.Range("a" & k - 2 & ":a" & k).EntireRow.Delete
            Next
            xlSheet1.Range("A1").Select
            xlSheet1.Range("A1").AddComment
            xlSheet1.Range("A1").Comment.Visible = False
            xlSheet1.Range("A1").Comment.Text Text:="10"
        End If
        xlSheet.rows(i & ":" & i).Copy    '复制该行
        rows = Val(xlSheet1.Range("A1").Comment.Text)
        xlSheet1.Range("A" & rows).Select
        xlSheet1.Paste    '粘贴该行
        xlSheet1.Range("A1").Comment.Text Text:=Str(rows + 1)
    Next

    For j = 2 To CountSheets    '调整每个表到最佳显示宽度
        Set xlSheet1 = xlBook.Worksheets(j)
        xlSheet1.Columns("A:A").EntireColumn.AutoFit
        xlSheet1.Columns("D:D").EntireColumn.AutoFit
        xlSheet1.Columns("K:K").EntireColumn.AutoFit
        xlSheet1.Range("A1").ClearComments
    Next

    xlSheet.Select
    xlSheet.Range("A1").Select
    xlBook.SaveAs FileName:=FileName    '保存工作表,结束时一定别忘了保存
    xlBook.Close (True)    '关闭工作簿 这里的True表示退出时保存修改
    xlApp.Quit    '结束EXCEL对象
    Set xlApp = Nothing    '释放xlApp对象
    Set xlSheet = Nothing    '释放xlApp对象
    Set xlSheet1 = Nothing    '释放xlApp对象
    Set xlBook = Nothing    '释放xlApp对象
    MsgBox "统计完成，请打开原文件进行查看！"
End Sub