|
If Combo1.Text = "" Then
MsgBox ("コースを選択して下さい")
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile App.Path & "\元フォーム.xls", App.Path & "\複写後フォーム.xls", True
Set fso = Nothing
' ----------------------------------------------------
' Connection オブジェクト作成
Set OpenDB = CreateObject("ADODB.Connection")
' ----------------------------------------------------
' 接続文字列作成
strConnection = "Provider=SQLOLEDB;Data Source=サーバ名;"
strConnection = strConnection & "Initial Catalog=DB名;"
strConnection = strConnection & "User ID=sa;"
strConnection = strConnection & "Password=;"
' ----------------------------------------------------
' DB 接続
On Error Resume Next
OpenDB.Open strConnection
If Err.Number <> 0 Then
Set OpenDB = Nothing
MsgBox (Err.Description)
Exit Sub
End If
On Error GoTo 0
' ----------------------------------------------------
' Recordset オブジェクト作成
Set rs = CreateObject("ADODB.Recordset")
' ----------------------------------------------------
SqlQuery = "select * from テーブル名 " & " where コース = '" & Combo1.Text & "'"
SqlQuery = SqlQuery & " order by コード"
' ----------------------------------------------------
' Recordset 取得
rs.Open SqlQuery, OpenDB
If rs.EOF Then
rs.Close
Set rs = Nothing
OpenDB.Close
Set OpenDB = Nothing
MsgBox ("対象データが存在しませんでした")
Exit Sub
End If
' ----------------------------------------------------
' Excel アプリケーションオブジェクト作成
Set ExcelApp = CreateObject("Excel.Application")
' ----------------------------------------------------
' Excel を表示させる
ExcelApp.Visible = True
' ベースBook を開く
Set MyBook = ExcelApp.Workbooks.Open(App.Path & "\複写後フォーム.xls")
' ベースSheet を選択
MyBook.Sheets("Sheet1").Select
' ベースSheet をCOPY
MyBook.Sheets("Sheet1").Copy (MyBook.Sheets("Sheet1"))
' 最初の名前で、Sheet 名を変更
MyBook.ActiveSheet.Name = rs.Fields("氏名").Value
' ブレイクキーの設定
BreakMain = rs.Fields("コード").Value
' 初回フラグ
bFirst = True
' 初期明細行位置
nRow = 10
Do While Not rs.EOF
Me.Refresh
If bFirst Then
bFirst = False
' タイトル部分のセット
MyBook.ActiveSheet.Cells(4, 3).Value = rs.Fields("コード").Value
MyBook.ActiveSheet.Cells(6, 3).Value = rs.Fields("氏名").Value
Else
' ブレイク処理
If BreakMain <> rs.Fields("コード").Value Then
' 新しいブックの作成
MyBook.Sheets("Sheet1").Select
MyBook.Sheets("Sheet1").Copy (MyBook.Sheets("Sheet1"))
MyBook.ActiveSheet.Name = rs.Fields("氏名").Value
' タイトル部分のセット
MyBook.ActiveSheet.Cells(4, 3).Value = rs.Fields("コード").Value
MyBook.ActiveSheet.Cells(6, 3).Value = rs.Fields("氏名").Value
' 初期明細行位置
nRow = 10
End If
End If
' 明細のセット
MyBook.ActiveSheet.Cells(nRow, 2).Value = rs.Fields("名称").Value
nRow = nRow + 1
' ブレイクキーの保存
BreakMain = rs.Fields("コード").Value
' 次データの読込み
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
OpenDB.Close
Set OpenDB = Nothing
| |