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
'*****************************************************************************