如何对Excel 宏 按照数据库的方式统计分析

Dim IsSourceWS As Boolean

Dim isTable1 As Boolean

Dim isTable2 As Boolean

Dim isTable3 As Boolean

IsSourceWS = False

isTable1 = False

isTable2 = False

isTable3 = False

sStartPath = ActiveWorkbook.Path & "/" & ActiveWorkbook.Name

If Worksheets.Count = 0 Then

    Exit Sub

Else

    For Each EacheWorksheet In Worksheets

       If EacheWorksheet.Name = "原表" Then

          IsSourceWS = True

       Else

          If EacheWorksheet.Name = "表1" Then

            isTable1 = True

          Else

              If EacheWorksheet.Name = "表2" Then

                  isTable2 = True

              Else

                 If EacheWorksheet.Name = "表3" Then

                     isTable3 = True

                 End If

              End If

          End If

       End If

    Next EacheWorksheet

End If

'*******************************没有原表则提示****************************************************

If IsSourceWS = False Then

    MsgBox "没有发现命名为'原表'的Sheet页签，请核对"

  Exit Sub

End If

'*********************************对Table1进行判断************************************************

If isTable1 = True Then

  Application.DisplayAlerts = False

  Worksheets("表1").Delete

  Set AddWorksheet = Nothing

  Set AddWorksheet = Worksheets.Add

      AddWorksheet.Name = "表1"

  Worksheets("表1").Move after:=Sheets(Sheets.Count)

Else

  Set AddWorksheet = Nothing

  Set AddWorksheet = Worksheets.Add

      AddWorksheet.Name = "表1"

  Worksheets("表1").Move after:=Sheets(Sheets.Count)

End If

'*********************************对Table2进行判断************************************************

If isTable2 = True Then

  Application.DisplayAlerts = False

  Worksheets("表2").Delete

  Set AddWorksheet = Nothing

  Set AddWorksheet = Worksheets.Add

      AddWorksheet.Name = "表2"

  Worksheets("表2").Move after:=Sheets(Sheets.Count)

Else

  Set AddWorksheet = Nothing

  Set AddWorksheet = Worksheets.Add

      AddWorksheet.Name = "表2"

  Worksheets("表2").Move after:=Sheets(Sheets.Count)

End If

'*********************************对Table3进行判断*****************************************************

If isTable3 = True Then

  Application.DisplayAlerts = False

  Worksheets("表3").Delete

  Set AddWorksheet = Nothing

  Set AddWorksheet = Worksheets.Add

      AddWorksheet.Name = "表3"

  Worksheets("表3").Move after:=Sheets(Sheets.Count)

Else

  Set AddWorksheet = Nothing

  Set AddWorksheet = Worksheets.Add

      AddWorksheet.Name = "表3"

  Worksheets("表3").Move after:=Sheets(Sheets.Count)

End If

'****************************************************连接数据库驱动************************************

lcconectionstring = "Provider=Microsoft.Jet.OLEDB.4.0;" & _

    "Data Source=" & sStartPath & ";" & _

    "Extended Properties=Excel 8.0;"

lccommandtext = "SQL语句"

Set loadodbconection = CreateObject("adodb.connection")

Set loadodbrecordset = CreateObject("adodb.recordset")

loadodbconection.Open lcconectionstring

loadodbrecordset.Open lccommandtext, loadodbconection, 3, 1, 1

Dim r As Integer

Dim f As Integer

r = 1

Application.DisplayAlerts = False

Application.StatusBar = "正在执行数据统计分析中,请稍后......."

'*****************************************************************************************

'**********************************提高速度，采用按行写入**********************************

'*****************************************************************************************

ReDim RowInfo(5) As String

For f = 0 To loadodbrecordset.Fields.Count - 1

    RowInfo(f) = loadodbrecordset.Fields(f).Name

Next

 RowInfo(f) = "备注"

Sheets("表2").Select

Sheets("表2").Range(Cells(r, 1), Cells(r, f + 1)).Value2 = RowInfo

ReDim RowInfo(5) As String

If loadodbrecordset.PageCount = 0 Then

 Application.StatusBar = ""

   Exit Sub

End If

While Not loadodbrecordset.EOF

    r = r + 1

    For f = 0 To loadodbrecordset.Fields.Count - 1

      RowInfo(f) = loadodbrecordset.Fields(f).Value

    Next

        Sheets("表2").Range(Cells(r, 1), Cells(r, f + 1)).Value2 = RowInfo

        Sheets("表2").Cells(r, f + 1) = "备注一下"

        loadodbrecordset.MoveNext

Wend

Sheets("表2").Cells.EntireColumn.AutoFit

'*****************************************************************************