そのままExp
Private Sub cmdExp_Click()
If MsgBox("表示データを出力しますか?", vbYesNo + vbQuestion) = vbYes Then
If IsNull(Me.txtSearch) And IsNull(Me.txtDateFrom) And IsNull(Me.txtDateTo) Then
CurrentDb.QueryDefs("出力").[[SQL]] = "SELECT 項目A,項目B,項目C" & _
"項目D,項目E FROM (" & Me.RecordSource & ") ORDER BY [項目A]"
Else
CurrentDb.QueryDefs("出力").SQL = "SELECT 項目A,項目B,項目C" & _
"項目D,項目E FROM (" & Me.RecordSource & ") WHERE " & Me.Filter & " ORDER BY [項目A]"
End If
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "出力", _
"C:\アドレス\抽出.xls", True
MsgBox "出力完了!" & Chr(13) & "「抽出.xls」をご確認ください。"
Else
Exit Sub
End If
End Sub
そのままExp2
Private Sub cmbExl_Click()
Dim exName As String
Dim exPass As String
'[[ユーザー関数]]UserName()でログインユーザー名取得
exName = Format(Date, "yymmdd") & "_ " & UserName() & "_AAA.xls"
exPass = CurrentProject.Path & "\" & exName
If MsgBox("表示データを出力しますか?", vbYesNo + vbQuestion) = vbYes Then
'select内でIIFを使う
CurrentDb.QueryDefs("出力").SQL = "SELECT 項目A,項目Bname AS 項目B," & _
"項目Cname AS 項目C,IIf(項目Da=5,項目D2,項目D1) AS 項目D," & _
"項目E FROM (" & Me.RecordSource & ") WHERE " & Me.Filter & " ORDER BY [項目A]"
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel9, "出力", exPass, True
MsgBox "出力完了!" & Chr(13) & "「" & exName & "」をご確認ください。"
Else
Exit Sub
End If
End Sub
シート指定
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "table", _
MyPath, False, "Sheet1!A:A"
結合されたもの
CurrentDb.QueryDefs("出力").SQL = "SELECT t_1.項目A,t_1.項目B,t_1.項目C, " & _
"t_2.A2,t_1.A2,t_3.B2," & _
"t_4-1.C2,t_4-2.D2 " & _
"FROM ((( t_1 LEFT JOIN t_2 ON t_1.A1 = t_2.A1) " & _
"LEFT JOIN t_3 ON t_1.項目D = t_3.B1) LEFT JOIN t_4-1 ON t_1.項目E1 = t_4-1.C1) " & _
"LEFT JOIN t_4-2 ON t_1.項目E2 = t_4-2.D1 ORDER BY [項目A]"
CurrentDb.QueryDefs("出力").SQL = "SELECT t_1.項目A,t_1.項目B,t_1.項目C, " & _
"t_2.A2,t_1.A2,t_3.B2," & _
"t_4-1.C2,t_4-2.D2 " & _
"FROM ((( t_1 LEFT JOIN t_2 ON t_1.A1 = t_2.A1) " & _
"LEFT JOIN t_3 ON t_1.項目D = t_3.B1) LEFT JOIN t_4-1 ON t_1.項目E1 = t_4-1.C1) " & _
"LEFT JOIN t_4-2 ON t_1.項目E2 = t_4-2.D1 WHERE " & Me.Filter & " ORDER BY [項目A]"
同フォルダExcelに
Private Sub cmdExp_Click()
On Error GoTo Err_Hander
Dim rs As DAO.Recordset
Dim xlApp As [[Excel]].Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet
Set rs = CurrentDb.QueryDefs("結果").OpenRecordset
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(CurrentProject.Path & "\照合.xls")
Set xlWs = xlWb.Worksheets("Sheet1")
xlWs.Range("A2:J1000").Clear
xlWs.Range("A2").CopyFromRecordset rs
xlWs.Range("A2:J1000").Font.Size = 9 'サイズ
xlWs.Range("A2:J1000").Font.ColorIndex = 43 '文字色
xlWs.Range("A2:J1000").Font.Bold = True '太字
xlWs.Range("A2:J1000").Interior.ColorIndex = 39 '背景色
xlWb.Save
xlWb.Close
Set xlWs = Nothing
Set xlWb = Nothing
Set xlApp = Nothing
Set rs = Nothing
MsgBox "完了しました。" & Chr(13) & "「照合.xls」をご確認ください。"
Else
Exit Sub
End If
[[Err]]_Hander:
If Err.Number = 1004 Then
MsgBox "「照合.xls」が開いています。" & Chr(13) & "閉じてください。"
End If
End Sub
シート指定
Dim xlApp As Object
Dim xlWb As Excel.Workbook
MyPath = CurrentProject.Path & "\TEST.xlsx"
Kill MyPath 'exp前にExcel削除
DoCmd.TransferSpreadsheet acExport, 10, "AAA", MyPath, True '10 → [[2007]].xlsx
'Excel設定
Set xlApp = CreateObject("excel.application")
Set xlWb = xlApp.Workbooks.Open(FileName:=MyPath)
xlApp.DisplayAlerts = False
'並替
xlWb.Worksheets("AAA").Activate
xlWb.Worksheets("AAA").Range("A:S").Sort Key1:=Range("A2"), order1:=xlAscending, _
Key2:=Range("C2"), order2:=xlAscending, Header:=xlYes
'設定
xlWb.Worksheets("AAA").Columns(1).Delete '1列目削除
xlWb.Worksheets("AAA").Cells.WrapText = False '折り返し無効
xlWb.Worksheets("AAA").Cells.EntireColumn.AutoFit '例全体のセル幅調整
xlWb.Worksheets("AAA").Cells.HorizontalAlignment = xlCenter '文字の配置
xlWb.Worksheets("AAA").Rows(1).Interior.ColorIndex = 11 '背景色
xlWb.Worksheets("AAA").Rows(1).Font.ColorIndex = 2 '文字色
'1列目/同一値の結合
'With xlWb.ActiveSheet
With xlWb.Worksheets("AAA")
i = 2
j = i + 1
Do While .Cells(j, 1).Value <> ""
If .Cells(i, 1).Value = .Cells(j, 1).Value Then
.Range(.Cells(i, 1), .Cells(j, 1)).MergeCells = True
.Range(.Cells(i, 1), .Cells(j, 1)).HorizontalAlignment = xlCenter
.Range(.Cells(i, 1), .Cells(j, 1)).VerticalAlignment = xlCenter
j = j + 1
Else
i = j
j = j + 1
End If
Loop
End With
xlWb.ActiveSheet.SaveAs MyPath, , , , , False 'バックアップ.xlkを作成しない
xlWb.Close SaveChanges:=True
xlApp.Quit
xlApp.DisplayAlerts = True
Set xlWb = Nothing
Set xlApp = Nothing
最終更新:2011年08月02日 14:28