Option Explicit
'Option Base 1
'使用ADO連接數(shù)據(jù)庫，添加ADO引用,在VBE下-》工具-》引用-》Microsoft ActiveX Data Objects 2.5 Library
'將sheet1中單元格A1的數(shù)據(jù)寫入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 '記錄制作時(shí)間變量

Public Sub excute()
Dim Title As String
Title = "導(dǎo)出用戶信息"
Do While 1 = 1
 createdate = InputBox("請輸入YYYYMMDD格式的報(bào)表制作日期：", Title)
 If Len(createdate) <> 8 Then
    MsgBox "日期格式錯(cuò)誤，請重新輸入", vbOKOnly + vbQuestion, "日期格式錯(cuò)誤提示"
Else

Call CreateReport(createdate) '填充數(shù)據(jù)子過程
End If
Exit Do
Loop
End Sub

Public Sub CreateReport(ByVal createdate As String)
Application.ScreenUpdating = False '屏幕刷新關(guān)閉
Application.DisplayAlerts = False '彈出信息警告框關(guān)閉
If Dir("G:\學(xué)習(xí)資料室\VBA學(xué)習(xí)資料\GetDataFromDataBase\" & createdate & ".xls") <> "" Then
   Kill "G:\學(xué)習(xí)資料室\VBA學(xué)習(xí)資料\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:\學(xué)習(xí)資料室\VBA學(xué)習(xí)資料\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當(dāng)編輯時(shí)立即鎖定記錄，最安全的方式
   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:\學(xué)習(xí)資料室\VBA學(xué)習(xí)資料\GetDataFromDataBase\" & createdate & ".xls")
      

  If Dir("G:\學(xué)習(xí)資料室\VBA學(xué)習(xí)資料\GetDataFromDataBase\" & createdate & ".hml") <> "" Then
     Kill "G:\學(xué)習(xí)資料室\VBA學(xué)習(xí)資料\GetDataFromDataBase\" & createdate & ".htm"
  End If
 

     xlbook.SaveAs Filename:= _
   "G:\學(xué)習(xí)資料室\VBA學(xué)習(xí)資料\GetDataFromDataBase\" & createdate & ".htm", FileFormat:=xlHtml, _
    ReadOnlyRecommended:=False, CreateBackup:=False

    xlbook.Close (True)
    'Workbooks("GetDataFromDataBase.xls").Close savechanges:=True'關(guān)閉工作簿同時(shí)保存
 
    xlApp.Quit
    createdate = ""
    Set xlbook = Nothing
    Set xlApp = Nothing '無此句EXCEL進(jìn)程將不能關(guān)閉
   Application.ScreenUpdating = True '屏幕刷新開啟
   Application.DisplayAlerts = True '彈出信息警告框開啟
End Sub

'############################單元格的合并與撤分###########################################

'合并單元格A1:C1，并寫入賦值為“用戶信息報(bào)表：制作于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 = "用戶信息報(bào)表制作時(shí)間：" & 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屬性判斷某個(gè)單元格是否為合并單元格的一部分,如果是,則利用unmerge方法或?qū)ergecells屬性設(shè)置為false,將合并單元格重新分解為獨(dú)立的單元格.
'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
'----------------------
'##############################################################################