匯出成excel才方便複製
按ctrl+T 設定使用元件 先載入
C:\WINDOWS\system32\ MSDATGRD.OCX
C:\WINDOWS\system32\Comdlg32.ocx
各拉出一個datagrid跟cmdlog 跟command以下是code
Option Explicit
Dim Conn As New ADODB.Connection
Dim Rs As New ADODB.Recordset

Private Sub Command1_Click()
ExportRecordSet Rs, cmdlog '另存新檔
Form1.MousePointer = 0
End Sub

Private Sub Form_Load()
Connect2SQLServer Conn '連接SQL資料庫
InitialRecordSet Rs '初始化 RecordSet
Rs.Open "SELECT top 20 CTM_NO FROM CTM order by ctm_no asc ", Conn '篩選條件
Set DataGrid1.DataSource = Rs
End Sub

'初始化 RecordSet
Public Sub InitialRecordSet(ByRef RsTemp As ADODB.Recordset)
With RsTemp
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockBatchOptimistic
End With
End Sub

'連線到 SQL SERVER 資料庫
Public Sub Connect2SQLServer(ByRef ConnTemp As ADODB.Connection)
Dim strConn As String
strConn = "Provider=SQLOLEDB.1;"
strConn = strConn + "Data Source=localhost;"
strConn = strConn + "User ID=sa;"
strConn = strConn + "Password=sa;"
strConn = strConn + "Initial Catalog=IT2010;"
ConnTemp.Open strConn
End Sub
Private Sub ExportRecordSet(ByRef RsExl As ADODB.Recordset, ByRef DialogFilePath As CommonDialog)

Dim intCnt As Integer
Dim fso As Scripting.FileSystemObject '此為引用 SCRRUN.DLL

Dim objExcel As Object 'As Excel.Application
Dim objWorkbook As Object ' As Excel.Workbook
Dim objWorksheet As Object ' As Excel.Worksheet
Dim strFileName As String
Const xlEdgeLeft = 7
Const xlEdgeTop = 8
Const xlEdgeBottom = 9
Const xlEdgeRight = 10
Me.MousePointer = vbHourglass
On Error GoTo ErrorHandle
'------------------------------------------------
' A0 複製 Excel 標準報表檔案。(AchieveStru.xls --> ?.xls
'------------------------------------------------

Set fso = New Scripting.FileSystemObject

DialogFilePath.Filter = "Excel (*.xls)|*.xls" '此為使用 COMDLG32.OCX 元件功能
DialogFilePath.ShowSave '另存新檔

strFileName = DialogFilePath.FileName
If Trim(strFileName) <> "" Then
If Dir(strFileName) <> "" Then '尋找strFileName儲存的檔案名稱是否真的存在
' 該檔案已存在
If MsgBox("此檔案已存在,您要覆蓋此檔嗎?", vbQuestion + vbYesNo, "匯出訊息") = vbYes Then
fso.DeleteFile strFileName, True
fso.CopyFile App.Path & "\TEST.xls", strFileName
Else
Set fso = Nothing
Exit Sub
End If
Else
fso.CopyFile App.Path & "\TEST.xls", strFileName ' copy test.xls儲存格格式
End If
Else
Set fso = Nothing
Exit Sub
End If
Set fso = Nothing
'------------------------------------------------
' B0 設定物件變數。
'------------------------------------------------
Set objExcel = CreateObject("EXCEL.Application") '產生一目前執行程式電腦中的 EXCEL 版本來產生 EXCEL 相關的引用
Set objWorkbook = objExcel.Workbooks.Open(strFileName)
Set objWorksheet = objExcel.Sheets(1)
objWorksheet.Name = "worksheetA" '工作表重新命名

' 是否出現確認訊息畫面。
objExcel.DisplayAlerts = False

'設定指定欄位的水平對齊格式
objExcel.range("A4").HorizontalAlignment = -4131

'設定指定欄位內容方式，通常都是填入主檔資訊
objExcel.range("A4") = "主檔資訊"

' 開始列號，資料會自第 11 列開始列出。
intCnt = 4

' 填入明細資料，將 RsExl 中的欄位資料選擇性的匯出或全都匯出到 Excel 檔案中。
With RsExl
.MoveFirst '移到第一筆資料，確保資料一定在第一筆
Do While Not .EOF
intCnt = intCnt + 1
objExcel.range("A" & Format(intCnt)).Value = .Fields("CTM_NO").Value '欄位內容
.MoveNext
Loop
End With

'指定某一範圍的上邊框線條格式為
objExcel.range("A" & Format(intCnt + 2) & ":M" & Format(intCnt + 2)).Borders.Item(xlEdgeTop).Weight = 2

'匯出主檔結尾資訊
objExcel.range("H" & Format(intCnt + 2)).HorizontalAlignment = -4152

objExcel.range("H" & Format(intCnt + 2)).Value = "TEST TEXT"

'告知使用者檔案匯至何處。
MsgBox "匯出至此一檔案：" & vbCrLf & vbCrLf & strFileName, vbOKOnly, "Excel Report"

ErrorHandle:
If Err > 0 Then
MsgBox Err.Description
Else
End If
'關閉及載出物件變數。
objWorkbook.Save
objExcel.Quit
Set objExcel = Nothing
Me.MousePointer = vbDefault
End Sub