数据统计.frm

专用的地球化学元素参数统计,可以一次同时统计一个*.mdb文件中的所有参数表的每一个数字性字段的"原始样品数,统计样品数,平均值,标准离差,变异系数, 极大值,极小值,众值,中位数"

         FV(1) = dbname
         FV(2) = STABLE
         FV(3) = sField
         FV(8) = TempData(0, n - 1)
         FV(9) = TempData(0, 0)
         FV(12) = " "
        Dsum = 0#
        
        
        For i = 0 To Dcount - 1
        
        Dsum = Dsum + TempData(0, i)
      
        Next
        Avg = Dsum / Dcount     '*********frist 平均值********
        Dsum = 0#
        For i = 0 To Dcount - 1
        
        Dsum = Dsum + (TempData(0, i) - Avg) ^ 2
      
        Next
       
        s = Sqr(Dsum / Dcount)         '*********frist 离差********
        

      '****************************************************
        k = 0
        j = 1
        m = Dcount - 1
 
        Do While True
      '***************去处离散数据*************************
            n = 0
        For i = 0 To m
             If TempData(k, i) < (Avg + 2 * s) And TempData(k, i) > (Avg - 2 * s) Then
                TempData(j, n) = TempData(k, i)
                n = n + 1
                
              End If
                
        Next
        
      '***************去处离散数据*************************
              m = n - 1
              
      '*****************求样品数&平均值&离差***********************************
        Dsum = 0#
        
        For i = 0 To m
        
        Dsum = Dsum + TempData(j, i)
      
        Next
        Avg = Dsum / (m + 1)               '*********平均值********
        Avg = Round(Avg, 2)

        Dsum = 0#
        For i = 0 To m
        
        Dsum = Dsum + (TempData(j, i) - Avg) ^ 2
      
        Next
        Dsum = Round(Dsum, 2)
        
        If Dsum = 0 Then
          GoTo allok
        Else
        ss = Sqr(Dsum / (m + 1))      '*********离差********
        End If
      '******************求样品数&平均值&离差*********************************

        If Abs(ss - s) <= 0.0001 Then GoTo allok
        s = ss
        tt = k
        k = j
        j = tt
        Loop

allok:
                               
         m = m + 1
         FV(4) = m
         FV(5) = Round(Avg, 5)
         FV(6) = Round(ss, 5)
         FV(7) = Round((ss / Avg), 5)
         
         
    '**********************求众值&中位数***********
    
    If (m - 2 * (m \ 2)) = 0 Then
        i = m / 2 - 1
        FV(11) = TempData(j, i)
        i = i + 1
        FV(11) = (FV(11) + TempData(j, i)) / 2#
    Else
        i = (m + 1) / 2 - 1
        FV(11) = TempData(j, i)
    
    End If
        m = m - 1
                            '求中位数完成
    
    
    Dim zzmax(2, 5000) As Double
     k = 0
     zzmax(0, k) = TempData(j, 0)
     zzmax(1, k) = 0
      For i = 1 To m
      
        If TempData(j, i) = zzmax(0, k) Then
        
           zzmax(1, k) = zzmax(1, k) + 1#
           
        Else
           k = k + 1
           zzmax(0, k) = TempData(j, i)
        End If
    
     Next
     tt = zzmax(1, 0)
     s = zzmax(0, 0)
     For i = 1 To k
    
      If zzmax(1, i) > tt Then
      
         tt = zzmax(1, i)
         s = zzmax(0, i)
     End If
     
     Next
    If tt > 0 Then
      FV(10) = s
    Else
      FV(10) = " "
    
    End If
  
                '求众值完成
    
    

    '**********************求众值&中位数***********

         

              
              '************数据统计完成*******************
              
              
'*****************************存入数据库*******************************

Dim InsertSQL As String
InsertSQL = FV(0) & "," & FV(1) & "," & _
          FV(2) & "," & FV(3) & "," & FV(14) & "," & FV(4) & "," & FV(5) & "," & _
          FV(6) & "," & FV(7) & "," & FV(8) & "," & FV(9) & "," & _
          FV(10) & "," & FV(11) & "," & FV(12)
            

ts.WriteLine InsertSQL


 
'*****************************存入数据库*******************************

                    '***************************************************'
                    '***************************************************'
                    '**                                               **'
                    '**                                               **'
                    '**                 工作完成！！！                **'
                    '**                                               **'
                    '**                                               **'
                    '***************************************************'
                    '***************************************************'
Exit Sub
rUNeRR:

MsgBox Err.Description

End Sub




Private Sub Command3_Click()

Command1.Enabled = False
Command3.Enabled = False
Dim sFile As String
sFile = Text1.Text

      
'**************选择数据库文件************


'**************打开数据库文件************
Dim DB As Database

   Set DB = OpenDatabase(sFile)

'**************打开数据库文件************


              '**************生成报告文件*********************
Dim i As Integer

   i = Len(sFile) - 4

            sFile = Left$(sFile, i)
     
     
            sFile = sFile & "统计成果.txt"
    
Dim fso As New FileSystemObject

    Set fso = CreateObject("Scripting.FileSystemObject")
        fso.CreateTextFile (sFile)
    Set fil = fso.GetFile(sFile)
    Set ts = fil.OpenAsTextStream(ForAppending)
    
    ts.WriteLine "数据类别,数据库名,数据表单,元素字段,原始样品数,统计样品数,平均值,标准离差,变异系数, 极大值,极小值,众值,中位数"
    
            '**************生成报告文件完成*********************

'**************取表&字段************
    Dim Fld As Field
    Dim Tbl As TableDef
    Dim STABLE As String
    Dim sField As String
    Const vbSpace As String = " "
    
    Dim DBcount1, DBcount2 As Integer
    Dim Jd1, Jd2 As Double
    
    DBcount1 = 0
    
    For Each Tbl In DB.TableDefs
    If Trim(Tbl.Name) <> "MSys" Then
    DBcount1 = DBcount1 + 1
    End If
    Next
    
    Jd1 = 0
    
    DoEvents
    Me.MousePointer = 11
    For Each Tbl In DB.TableDefs
        STABLE = Tbl.Name

       
        If Left$(STABLE, 4) <> "MSys" Then
         DBcount2 = Tbl.Fields.Count
         
         Jd2 = 0
            For Each Fld In Tbl.Fields

                   If Fld.Type = 2 Or Fld.Type = 3 Or Fld.Type = 4 Or Fld.Type = 6 Or Fld.Type = 7 Then    '*****************只处理数字型字段*****************
            
                   sField = Fld.Name
                    If InStr(sField, vbSpace) Then
                        sField = "[" & sField & "]"
                    End If
                    If InStr(STABLE, vbSpace) Then
                        STABLE = "[" & STABLE & "]"
                    End If

                    '************数据处理*******************
                    
                    
                    Call dataEDIT(DB, STABLE, sField, fso, sFile)
                    
                    '************数据处理*******************
                  
                    dxjd.Value = Jd2 / DBcount2 * 100#
                    Label5.Caption = Round(Jd2 / DBcount2 * 100#, 2) & "%"
                    dxjd.Refresh
                    Jd2 = Jd2 + 1
    
                    Else
                     MsgBox "在_" & Tbl.Name & "_表中，" & Chr(10) & Chr(13) & Fld.Name & "_字段的类型为非数字型，处理过程中将被忽略！", , "字段错误信息提示"
                              
                    End If
             Next
             
        End If
        zjd.Value = Jd1 / DBcount1 * 100#
        zjd.Refresh
        Label6.Caption = Round(Jd1 / DBcount1 * 100#, 2) & "%"
        Jd1 = Jd1 + 1
    Next
    
ts.Close
'**************取表&字段************
zjd.Value = 100
dxjd.Value = 100
Label5.Caption = "100.0%"
Label6.Caption = "100.0%"
Command2.Caption = "完成 &Y"
DB.Close
Command1.Enabled = True
Me.MousePointer = 1
End Sub