exp

※上記の広告は60日以上更新のないWIKIに表示されています。更新することで広告が下部へ移動します。

---

そのまま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