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

http://s13/middle/6e825898x9539dd46e2fc&690

http://s14/middle/6e825898x9539dd46e23d&690

http://s13/middle/6e825898x9539dd5622bc&690