Option Explicit
'Option Base 1
'使用ADO连接数据库，添加ADO引用,在VBE下-》工具-》引用-》Microsoft ActiveX Data Objects 2.5 Library
'将sheet1中单元格A1的数据写入sheet2的A1单元格，只需在sheet2的A1单元格写公式
'=IF(Sheet1!A1="","",Sheet1!A1)即可
Public Cn As ADODB.Connection
Public cmd As ADODB.Command
Public rs As ADODB.Recordset
Public createdate As String '记录制作时间变量
Public Sub excute()
Dim Title As String
Title = "导出用户信息"
Do While 1 = 1
createdate = InputBox("请输入YYYYMMDD格式的报表制作日期：", Title)
If Len(createdate) <> 8 Then
MsgBox "日期格式错误，请重新输入", vbOKOnly + vbQuestion, "日期格式错误提示"
Else
Call CreateReport(createdate) '填充数据子过程
End If
Exit Do
Loop
End Sub
Public Sub CreateReport(ByVal createdate As String)
Application.ScreenUpdating = False '屏幕刷新关闭
Application.DisplayAlerts = False '弹出信息警告框关闭
If Dir("G:\学习资料室\VBA学习资料\GetDataFromDataBase\" & createdate & ".xls") <> "" Then
Kill "G:\学习资料室\VBA学习资料\GetDataFromDataBase\" & createdate & ".xls"
End If
Dim xlApp As New Excel.Application '或者Dim xlApp As Excel.Application:Set xlApp = Excel.Application
Dim xlbook As New Excel.Workbook
Set xlbook = xlApp.Workbooks.Add("G:\学习资料室\VBA学习资料\GetDataFromDataBase.xls")
Set Cn = New ADODB.Connection
'Cn.ConnectionString = "provider= Microsoft OLE DB Provider for SQL Server;user id=sa;data source=127.0.0.1;persist securityinfo=True;initial catalog=test;password=sa;"
Cn.ConnectionString = "provider=sqloledb;user id=sa;data source=127.0.0.1;Database=test;password=sa;"
Dim strselectall As String
strselectall = "select * from tbLogin"
Set cmd = New ADODB.Command
Set rs = New ADODB.Recordset
Cn.Open
Set rs.activeconnection = Cn '此句可省略
rs.cursorlocation = adUseServer
rs.Open strselectall, Cn, adOpenKeyset, adLockOptimistic
'adLockOptimistic当编辑时立即锁定记录，最安全的方式
Dim i As Variant
With xlbook.Worksheets("sheet1")
If rs.RecordCount > 0 Then
For i = 0 To rs.RecordCount - 1
.Cells(i + 3, "A").Value = Trim(rs("ID"))
.Cells(i + 3, "B").Value = Trim(rs("UserName"))
.Cells(i + 3, "C").Value = Trim(rs("UserPwd"))
If rs.EOF <> True Then
rs.MoveNext
End If
Next i
End If
End With
rs.Close
xlbook.Worksheets("sheet1").Cells(1, "C").Value = createdate
xlbook.Sheets("sheet1").Visible = False
xlbook.SaveAs ("G:\学习资料室\VBA学习资料\GetDataFromDataBase\" & createdate & ".xls")
If Dir("G:\学习资料室\VBA学习资料\GetDataFromDataBase\" & createdate & ".hml") <> "" Then
Kill "G:\学习资料室\VBA学习资料\GetDataFromDataBase\" & createdate & ".htm"
End If
xlbook.SaveAs Filename:= _
"G:\学习资料室\VBA学习资料\GetDataFromDataBase\" & createdate & ".htm", FileFormat:=xlHtml, _
ReadOnlyRecommended:=False, CreateBackup:=False
xlbook.Close (True)
'Workbooks("GetDataFromDataBase.xls").Close savechanges:=True'关闭工作簿同时保存
xlApp.Quit
createdate = ""
Set xlbook = Nothing
Set xlApp = Nothing '无此句EXCEL进程将不能关闭
Application.ScreenUpdating = True '屏幕刷新开启
Application.DisplayAlerts = True '弹出信息警告框开启
End Sub
'############################单元格的合并与撤分###########################################
'合并单元格A1:C1，并写入赋值为“用户信息报表：制作于XXXX年XX月XX日”
Public Sub mergeA1C1(ByVal createdate As String)
Dim xlbookmerge As Workbook
Set xlbookmerge = ThisWorkbook
Worksheets(1).Select
'Range("A1:C1").MergeCells = True '合并单元格A1:C1 或者使用Range("A1:C1").merge
'MsgBox Range("A1").MergeArea.Address'查看合并单元格地址
'Range("A1").Value = "用户信息报表制作时间：" & Left(createdate, 4) & "年" & _
' Mid(createdate, 5, 2) & "月" & _
' Right(createdate, 2) & "日"
Range("C1").Value = Left(createdate, 4) & "年" & Mid(createdate, 5, 2) & "月" & Right(createdate, 2) & "日"
End Sub
'------------------------------------------
'取消合并的单元格begin
'首先利用mergearea属性判断某个单元格是否为合并单元格的一部分,如果是,则利用unmerge方法或将mergecells属性设置为false,将合并单元格重新分解为独立的单元格.
'Private Sub 取消合并单元格()
'Dim myrange As Range
'Set myrange = Range("A1")
'If myrange.MergeArea.Address = myrange.Address Then
'MsgBox "该单元格不是合并单元格的一部分"
'Else
'myrange.MergeArea.MergeCells = False'或者myrange.MergeArea.UnMerge
'End If
'Set myrange = Nothing
'End Sub
'取消合并的单元格end
'----------------------
'##############################################################################
