2019年9月19日木曜日

Access途中

Private Sub bu_Quer Click0 
マスタ追加 
Get item 
Get Field 
End Sub 

‘日別担当者〔モジュール〕フィールドリスト取得 
Public Sub Get_Field()
On Error GoTo Err_GetField 
Dim db As DAO.Database
Dim Tableloop As DAO.TableDef 
Dim Fld As DAO.Field 
Dim strTablename As String 
Dim Tdf As DAO.TableDef 

Dim strSQL As String 'SQL文 
Dim strType As String  ‘型名 

‘typeの置換は定数でselect case 

DoCmd.SetWarnings False 
‘テーブルのリストを初期化 
DoCmd.RunSQL "DELETE * FROM W_table_list 

‘DBの各テーブル名を見て、システムテーブルで無いものを判別して処理 
Set db = CurrentDb 
strDbname = CurrentProject.Name 
strdate = Date
For Each Tableloop In db.TableDefs 

strTablename = Tableloop.Name 

If Left(strTablename, 2) <> “MS” Then 
Set Tdf = db.TableDefs(strTablename) 
For Each Fld In Tdf.Fields 
'typeの置換 
Select Case Fld.Type 
Case 1
‘dbBoolean 
strType = “Boolean”

Case 2 
'dbByte 
strType = “Byte”

Case 3 
‘dblnteger 
strType = “Integer" 

Case 4 
' db Long 
strType = “Long”

Case 5 
‘dbCurrency 
strType = “Currency”

Case 6 
' db Single 
strType = “single”
Private Sub bu_select Click()
'==================================================
'エクセルのシート名を集めてテーブルに保存したものをフォームに表示
'==================================================

Dim rs As DAO.Recordset ' レコードセット用変数
Dim xlsApp As Excel.Application 'アプリケーション用オブジェクト変数
Dim xlsWkb As Excel.Workbook  'ワークブック用オブジェクト変数
Dim i As Integer 'ループ用変数1指定したエクセルファイルを開く処理
Dim mess As String

'フォルダ名¥ファイル名を格納
mesg = getFilePicker

'バスワード付きのエクセルファイルを團く

Set xlsApp = CreateObject("Excel.Application")

Set xlsWkb _ xlsApp.Workbooks.Open( _
FileName:ニmess, ReadOnly:=True _
, Password:="dcm5241"),WriteResPassword:="")
'Fファイル選択のファイルネームテキストボックスにファイル名を入れる。

 Me!L_Filename.Visible = True: Me!tx_Filename.Visible = True
Me!tx_Filename = mesg


'T_選択シート名にデータが入っていたら削除する。
Do Cmd.SetWarnmgs False
Do Cmd.runSQL "DELETE T_選択シート名.* FROM T_選択シート名;"
DoCmd.SetWarnmgs True
Set rs = CurrentDb.OpenRecordset("T_選択シート名") 'シート名の保存

For i = 1 To xlsWkb.Sheets.Count
rs.Add New
rs!シート名= xlsWkb.Sheets(i).Name
rs. Up date
Next i
'クローズ処理
rs.Close: Set rs =Nothing
xlsWkb.Close Save Changes:_False Set xlsWkb = Nothing
xlsApp-Quit: Set xlsApp = Nothing
Me!F選択シート名Visible = True
Me!F_選択シート名.Requery
Me!bu inport.Visible = True
 end sub

 Private Sub bu_inport_Click()
'================================================
'<<インポート>>ボタン_エクセルのシート名をフォームで指定し、範囲を指定してインポー
'================================================
Dim db As DAO.Database
 Dim rs As DAO.Recordset 'レコードセット用変数
 Dim inrs As DA0.Recordset 'インポート先のレコードセット変数
Dim inrg As String lインポート元のインポート範囲
Dim i As Integer
Dim xlsApp As Excel.Application
Dim xlsWb As Excel.Workbook
Dim xlsWs As String
Dim inrsTbl As String
Set db = CurrentDb
Set rs = db.OpenRecordset(Name:="T_選択シート名fl, Type:=db OpenTable) 'インポートシート名の指定テーブル
Set inrs = db.OpenRecordset(Name:=Me.F_選択シート名Form.テーブル名Value, Type:=dbOpenTable) ンポート先のテーブル
Set xlsApp = CreateObject("Excel.Application")
Set xlsWb _
= xlsApp.Workbooks.Open( _
FileName:=Me!tx_Filename, ReadOnly:=False _
, Password:="dcm5241",WriteResPassword:="")
'インボートァーブル名に" 01 01 01"を付けたクエリを実行してテーブルを削除
For i = 1 To rs.RecordCount
If rs.Fields(1).Value =True Then
xlsWs = rs. Fields(0).Value
InrsTbl = Me.F_選択シート名.Form.テーブル名.Value
inrg=Me.F選択シート名.Form.インポート範囲.Value 'インポート元のインポート範囲
Do Cmd.SetWarmngs False

DoCmd.Open Query '"01_01_01"&InrsTbl, acViewNormal, acEdit
DoCmd.TransferSpreadsheet , acSpreadsheetTypeExcell2, inrsTbl, Me!tx_Filename, True, xlsWs & "!"&inrg
end if

rs.movenext
next i
& inrg

xlsWb.Close SaveChanges:=False
xlsApp.Quit
Set xlsWb = Nothing
xlsWs = ""
Set xlsApp =Nothing
rs.Close: Set rs = Nothing
inrs.Close: Set rs _ Nothing
db. Close
Set rs = Nothing
Set inrs = Nothing
Set db = Nothing
DoCmd.SetWarnings True
MsgBoX"インポートしました。"
end sub



'================================
'ファイル選択ダイアログ
'================================
Option Compare Database
Function getFilePicker(Optional dTitle As String = llファイル選択")
'2003以降
Canst mso FileDialogFilePicker As Integer = 3
Dim fDlg As Object
Set fDlg = Application. FileDialog(mso FileDialogFilePicker)
fDlg.Title = dTitle
fDlg.InitialFileName = myDeskTopPath
fDlg.AllowMultiSelect = False
fDlg. Filters.Clear
fDlg. Filters.Add "すべてのファイル","*.*"
fDlg.Filters.Add "CSVファイル(*.csv)","*.csv"
fDlg. Filterlndex = 1
If fDlg.Show Then get FilePicker = fDlg.SelectedItems(1) Else getFilePicker =""
End Function


sub SheetN()
'================================
'エクセルのシート名を集める
'================================
Dim rs As DAO.Recordset lレコードセット用変数
Dim xlsApp As object Iアプリケーション用オブジェクト変数
Dim xlsWkb As Object 'ワークブック用オブジェクト変数
DimiAs Integer 'ループ用変数|指定したエクセルファイルを聞く処理
Dim mess As String
mesg = get FilePicker
Set xlsApp _ CreateObject("Excel.Application")
Set xlsWkb = xlsApp.Workbooks.Open( _
FileName:_mesg, ReadOnly:=True _
, Password:="dcm5241",WriteResPassword:="")
Set rs = CurrentDb.OpenRecordset("tbI A") 'シート名の保存
For i = 1 To xlsWkb. Sheets.Count
rs.AddNew
 rs!シー ト名= xlsWkb.Sheets(i).Name
rs.Update
Next i
'クローズ処理
rs.Close: Set rs = Nothing
xls Wkb.Close Save Changes:=False Set xlsWkb = Nothing
xlsApp-Quit: Set xlsApp =Nothing
End Sub


 恥dS山
Function ToExcel 週次成果()'テンプレを呼び出してエクスポート
'★結合や色が入ったシート用
 Dim Pass As String
 Dim DBAs DAO.Database
 Dim QRs1 As DAO.Recordset
 Dim QRs2 As DAO.Recordset 
 Dim QRs3As DAO.Recordset Dim SHn1 As 
 Dim SHn2 As 
 Dim SHn3 As Dim TSHn1 As String 
 Dim TSHn2 As String 
 Dim Fmm As String 
 Dim Kmm As String 
 Dim Smm As String 
 Dim yymmdd As String 
 Dim Vsname As String 
 Dim fname As String 
 Dim sname As S仕ing 
 Dim xlsApp As Object 
 Dim Vfname As String
 Dim QRslNme As String 
 Dim QRs2Nme As String '出力先パスを指定
 Pass = "C:YTemp4O3＿エクスポート￥01＿支店展開用賑売成果￥' 

'#＝========Access の処理＝========＝井存
 'データベースを参照
 Set DB=CurrentDb()
 Set QRs1 = DB.OpenRecordsetぐ'03 02_ 02 「単月表紙」「貼付用」●''）'〔代アカ 未ア力）yyyymm
 Set QRs2 = DB.Ope迅ecordset("05_03_01 「単月表紙) 「貼付用」「直営」●''）    yyyymm
Set:QRs3=DB.OpenRecordset("02_01_01元データA")【直営含】元データ

'#－-----------Excel の処理－----------－#
'「出力先」ファイルやシート名を指定します。Kmm=Me!【月」
Smm=Me!【年月t x t}
yymmdd = Me!「年付》集計期間」Fmm =fPass ＆''「週次速報」''＆Kmm ＆''期販売成果''＆yymmdd &".xlsx"TSHn1 ＝''〔代アカ1 候補－‘未アカ」yyyymm"
TSHn2＝''（（直営》yyyymm"
SHn1 ＝''〔代アカ・候補・未ア力〕''& Smm 
SHn2＝''（（直営》''＆Smm
SHn3 =''「直営含」元データ''
 「テンプレ」ファイルやシート名を指定します。fname = fPass &“テンプレ￥「週次速報」m月期販売成果申姐sx"'出力先のMs Excelを利用できるように設定します。 
Set xlsApp=CreateObject("Excel.App氏ation")
'テンプレのパスを指定します。
Set xlsWkb=xlsApp.Workbooks.Open(_ 
FileName:=fname, ReadOnly:=False_ 
Password:=", WriteResPassword:=")'テンプレのSheet名を指定します。
xl唇App.Wo永sheets(TSHn1).Select
'入っているデータを削除します。
xlsApp.Worksheets(TSHn1).Range("A2:EB65000").C琵arContents
'セル行・列を基点としてデータを出力します。 
xlsApp.Cells(2, 1).CopyFromRecordsetTQRs 1 
xlsApp.Worksheets(TSHn1).Name=SHn1
テンプレのSheet名を指定レます。
 xis節p.\石rksheets(T5Hn2).Select '入っているデータを削除します。
 xisApp.Worksheets(TSHn2).Range("A2:EB65000").ClearContents tセル行・列を基点としてデータを出力します。 
 xlsApp.Cells(2, 1).CopyFromRecordset QR昭 
 xlsApp.Worksheets(TSHn2).Name=: SHn2 'テンプレのSheet名を指定します。
 xlsApp.W吐ksheets(SHn3).Select '入っているデータを削除し・ます。 
 xlsApp.Worksheets(SHn3).Range("A2:EB65000").ClearContents 'セル行・列を基点としてデータを出力します。 
 xlsApp. Ce恥（2, 1).CopyFromRecordset QRs3    xlsApp.DisplayAlerts=False 
    xlsWkb.SaveAs FileName:=Fmm 
    xlsWkb.Close
    DisplayAlerts=True
    xlsApp. Quit
    Set xlsApp=Nothing  DoCmd.TransferSpreadsheet acExport, 10, "04_02_O1 「累積」法＿新規P1●クロス'',Fmm, True,"〔代アカ・ 
候補・未アカ〕法＿新規PT" Set DB=Nothing 
 Set Q恥1=Nothing 
 Set QRs2=Nothing 
 Set QRs3=Nothing
 TSHn1＝'''' 
 TSHn2＝'1'' 
 SHn1＝'''1 
 SHn2＝'''' 
 SHn3＝''''
皿sgBox "Excelへ出力しました'' End Function★★色も指定してエクスポート
Sub ToExcel一次代理店0
'★★クエリ内の一次代理店名からリストを取得・リスト名と同じ名前のシートの指定したセルにデータを貼付け
★★Dim DB As DAO.Database 
Dim Ri As DAO.Recordset 
Dim R2 As DAO.Recordset 
Dim R3 As DAO.Recordset
Dim QRs1 As DAO.Recordset 
Dim QRs2 As DAO.Recordset 
Dim QRs3As DAO.Recordset 
Dim QRs4As DAO.Recordset 
Dim QRs4s As String
Dim QRs4a As String
Dim QRs5 As DAO.Recordset 
Dim QRs6 As DAO.Recordset 
Dim Qi As QueryDef
Dim Q2 As QueryDef
Dim Q3 As QueryDef
Dim SQL_Txt As String
Dim SQL_Txt2 As String 
Dim SQL_Txt3 As String 
Dim fPass As String
Dim fname As String'出力先パスとファイル名
Dim fna血e2 As String'出力先パスとファイル名元データシート 
Dim Rfname As String'リネーム後のファイル名
DimR釦ame2 As String'リネーム後のファイル名元データシート
Dim sname As String'出力先シート名
Dim sname2 As String'出力先シート名元データシート
Dim xlsWkb As Object'ワークブック用オブジェクト変数
Dim xlsApp As Object
Dim xlSheet As Object
Dim fn2p As String
Dim iAs Long
Dim COLR As String'セル色・
 1出力先パスを指定
 fPass = "C:￥Temp￥03＿エクスポート￥03＿要望数￥'  1#＝========Accessの処理＝========＝井井
 'データベースを参照
 Set DB=CurrentDbO '作業用クエリを作成
 SetQl=DB.CreateQueryDef("Ql_"&Format(No曳''yyyymmddhhnnss")) 
 Set Q2=DB.CreateQuerypef(りQ2_"&Format(Now, "yyyymmddhhnnss")) 
 Set Q3=DB.CreateQue増Def("Q3_"&Format(No曳''yyyymmddhhnnss"))
 'ファイル名やシート名用の一覧を作成
 SQしTxt = "SELECT DISTINCT 一次代理店名＿略FROM 09_02_01 【貼付用元) “'ファイル名用
 S叫T武2 ="SELECT DISTINCT 一次＿対象，集＿対象，一次代理店名＿略FROM 09_02_01 【貼付用元】“
'抽出用
 SQL_Txt3 = "SELECT DISTINCT 集―対象，RGBFROMO9_ 02_ 01 「貼付用元」'''シート名用 '一覧をレコードとして扱う 
 SetRi=DB.OpenRecordset(SQL_Txt)  'ファイル名用 
 Set R2=DB.OpenRecordset(SQL_Txt2) '抽出用 
 Set R3=DB.OpenRecordset(SQL_Txt3) 'シート名用 '**=＝一＝=＝ファイル単位一一＝===＝★★
 R1.MoveFirst
 Do Until R1.EOF    '##------------Excelの処理－----------－#
       t出力先のファイル名を決めます。fPass & Ri!一次代理店名」略＆巧xlsx“とすると'一次代理店別のフ
ァイルを作成します。      '以下はフォーマットとして使用するファイ及なので名称は固定でOK0
      fname= fPass &" [02_03_03] 週次目標達成状況フォーマット．xlsx"          fname=fPass&Ri！一次
代理店名＿略＆''個人実績．xlsx"
      sname＝''一次代理店名''                            'Ri!一次代理店名＿略        '出力先のMs Excelを利用できるように設定します。 
      Set xlsApp=CreateObjectぐ'Excel.Application")
  ：電遍凱ファイルのパスを指定します。
  畿t xlsWkb=xlsApp.W吐kbooks.Open(_ 
  FileName:=fname, ReadOnly:=False_ 
  ,Password:=", WriteResPassword:=") '★★＝====＝シート単位＝====＝一★★ 
 R3.MoveFirst『・
 Do Until R3.EOF  'クエリの書き換え（SQL切セット）証も
  Q1.SQL ='' SELECT* FROM 09_02_01 【貼付用元」WHERE 一次代理店名＿略＝1性＆RI!一次代理店名 
＿略＆川AND 集―対象g''l&R望集＿対象＆lflORDER BY 運営店名“"SELECT *FRO斑03_ 02_ 01 【貼付 
用元」WHERE 一次代理店名＿略＝" & Ri！一次代理店名＿略＆川''
  Q2.SQL＝唱ELECT * FROM 09_02_03【貼付用元】一次代理店計w査ERE 一次代理店名＿略＝'''＆Ri! 
一次代理店名二略＆"AND 集＿対象＝'“&R3!集―対象＆'''“
  Q3.SQL = "SELECT * FROM 09_02_02 【貼付用元】運営店計WHERE 一次代理店名＿略＝" & Ri！一 
次代理店名＿略＆"AND 集＿対象＝'“&R3!集―対象＆'''''  Set QRs1=DB.OpenRecordset(Q1 .Name) 
  Set QRs2=DB.OpenRecordset(Q2.Name) 
  Set QRs3=DB.OpenRecordset(Q3.Na血e)
  Set QRs4 = DB.OpenRecordset("01_01_03適用日''）
  QRs4s = QRs4(''年付》集計期間'アファイル名の後に付ける文字
  QRs4a = QRs4(“適用日最大''）'シートのAlに入れる文字
  COLR=R3!RGB.Value
  'コピー先の位置取得
  lngCnt=xlsApp.Worksheets.Count   シートコピー
  Set xlSheet=xlsApp.Worksheets(sname) 
  xISheet.Copy after:=xlsApp.Worksheets(lngCnt)  'シート名変更
  'シートを増やしたのでもう一回数える
  lngCnt=xlsApp.Worksheets.Count  Set xlSheet=xlsApp.Worksheets伽gCnt) 
  xlSheet.Name =R3！集＿対象  'Sheet名を指定しま撃b
     d誕かp.Worksheets(xlSheet.Name).Select      t入っているデータを削除します。
     x1sApp.Worksheets(x1Sheet.Name).Range("A4CC46, A50:CC5O, A55:CC 100").ClearContents 
      'セル行・列を基点としてデータを出力します。：
     xlsApp.Cells(4, 1).CopyFromRecor聾et QRs1 一次代理店データ
     xlsApp・Cells(50, 1).CopyFromRecord託t QRs2 '一次代理店計「・ 
     xlsApp.Cells(55, 1).CopyFrornRe叩rdset QRs3 '運営店計
     xlsApp.Cells(1, 1).Va知e〒 QRs4a '日付＿:_:: 
     xlsApp.Cells(1, 31).Value三R3！集＿対象'表見出しになるオーダ種男リ
     xlsApp.Workshee加（xl甑eet.Name).Range("Gl :BE3, G47:BE49, G52:BE54").Interior.Color=COLR 見出し色
R 見出し色    R3.MoveNext 
    Loop    '出力先のパスとファイル名を指定します。
    Rfname = fPass &''出力￥[02_03_03」週次目標達成状況〔"&R1！一次代理店名＿略＆"J" & QRs4s & ".xlsx"    'ファイル名の後ろに日付を付けて保存します。 
    xlsApp.DisplayAlerts=False
    xlsApp.Worksheets(sname).Delete 'テンプレシートを削除
    xlsWkb.SaveAs FileName:=Rfname,_ 
    Password:="dcm5241"
    xlsApp.DisplayAlerts=True
    xlsApp.Quit   R1.MoveNext 
   Loop   DoCmd.DeleteObject acQuery, Qi .Name 
   DoCmd.DelteObject acQuery, Q2.Name 
   DoCmd.DeleteObject acQuery, Q3.Name
   SetQl=Nothing 
   Set Q2=Nothing 
   Set Q3=Nothing
    xis極p.w吐ksheets(xlSheet.Name).Select    t入っているデータを削除します。
    x1sApp.Worksheets(x1Sheet.Name).Range("A4CC46, A50:CC5O, A55:CC100").ClearContents    1セル行・列を基点としてデータを出力します97
    xlsApp.Celis(4, 1).CopyFromRecor心et QRs1 '一次代理店データ 
    xlsApp.Cells(50, 1).CopyFro血R配or臨et QRs2 '一次代理店計
    xlsApp.Cells(55, 1).CopyFrom航cordset QRs3 '運営店計
    xlsApp.Cells(1, 1).Va猫昨QRs4a '日付な
    xlsApp.Ceils(1, 31).Value = R3！集＿対象'表見出しになるオーダ種男リ
見出し色xlsApp.Workshee飴（(x瑠heet.Name).Range("G1:BE3, G47:BE49, G52:BE54").Inte誠br.Color=COLR  R3.MoveNext 
  Loop  '出力先のパスとファイル名を指定します。
  Rfname = Pass &''出力￥[02_03_03」週次目標達成状況〔"&R1！一次代理店名＿略＆"]" & QRs4s & ".xlsx"  'ファイル名の後ろに日付を付けて保存します，
  xlsApp.DisplayAlerts=False
  xisApp.Worksheets(sname).Deiete ・．テンプレシートを削除 
  xlsWkb.SaveAs FileName:=Rfname,_
  Password:="dcm5241''ゴ
  xlsApp.DisplayAlerts=True 
  xlsApp.QuitRi .MoveNext 
LoopDoCmd.DeleteObject acQuery, Qi .Name 
D記md.DeleteObject acQuery, Q2.Name 
DoCmd.DeleteObject acQuery, Q3.Name
SetQl=Nothing 
Set Q2=Nothing 
Set Q3=Nothing
fnai直h亀''''
      云ー厘1
血ame2 国国一こニコ      - tlll
斑name
R垣ame2＝'''' 
sname=1111 '#－----------－元データシートの処理－----------－#＝ 
  '#=========Accessの処理＝===＝〒＝と零難燐
 'データベースを参照
 Set DB=CurrentDbO fn2p=" [02_03_O1】週奥目標達成状況フォーマットーALL" 
 fname2=fPass&fn距義''.xlsx" sname2 =''元データ''
 Set QRs4 = DB.OpenRecordset("O1_O1_03適用日''） 
 QRs婚＝QRs4(''年付》集計期間''）
 QRs4a = QRs4(''適用日最大''）
 '作業用クエリを作成
 SetQl DB.CreateQueryDef("Ql_"&Format(No叫 yyyymmddhhnnss")) 
 Set Q2 DB.CreateQueryDef("Q2_"&Format(No曳 yyyymmddhhnnss"))
 'テーブルのオーダ種別一覧を取得
 SQL_Txt = "SELECT DISTINCT集＿対象，RGB FROM 09_02_O1 「貼付用元」''
 'Ri＝オーダ種別一覧 
 SetRi=DB.OpenRecOrdset(SQL_Txt)   '#－--------－'－Excelの処理－----------－#   '出力先のファイル名を決めます。Pass & Ri!一次代理店名＿略＆".x'sx“とすると'一次代理店別のフアイ 
ルを作成します。
   '出力先のMs Excelを利用できるように設定します。 
   Set xlsApp=CreateObject("Excel.Application")
   'Excel ファイルのパスを指定します。
   Set xlsWkb=xlsApp.Workbooks.Open(_ 
   FileName:=fname2, ReadO皿y:=False_ 
   ,Password:=", WriteResPassword:=")
  ぎ実★三髪一＝一＝Accessの処理シート単位 責責  1オ→ダ種別ごとに処理
 R1.MoveFirst
 Do Until Ri.EOF    'クエリの書き換え（SQLのセッ下）二
    Q1.SQL = "SELECT * FRO雄09四2 01 【貼付用元】WHERE 集吋象＝"& Ri！集＿対象＆" ORDER 
BY 販売店名“"SELECT * FRO班0み－02_ 01 【貼付用元】WHERE 一次代理店名＿略＝m &RI!一次代理店 
名＿略＆'''''
    Q2.SQL = "SELECT * FROM 09_03_01 「貼付用元」東北計WHERE 集―対象ゲ''＆Rl！集＿対象＆''''' 
"SELECT * FROM 03四2加1鮎付用元】WHERE 一次代理店名＿略＝"& Ri!一次代理店名＿略＆tll''    Set QRs5 DB.OpenRecordset(Q1 .Name) 
    Set QRs6 DB.OpenRecordset(Q2.Name) 
    COLR三Ri !RGB.Value    'コピー先の位置取得
    lngCnt=xlsApp.Worksheets.Count    'シートコピー
    Set xlSheet=xlsApp.W吐ksheets(sname2) 
    xlSheet.Copy after:=xlsApp.Wo費sheets(lngCnt)    'シート名変更
    'シートを増やしたのでもう一回数える 
    lngCnt=xlsApp.Worksheets.Count    Set xlSheet=xlsApp.Worksheets(lngCnt) 
    xlSheet.Name=Ri！集＿対象    'Sheet 名を指定します。 
    xlsApp.Worksheets(xlSheet.Name).Select    1入っているデータを削除します。
    xlsApp.Worksheets(xlSheet.Name).Ra昭e("A4:CC i68,G172:CC2O1").ClearContents    'セル行・列を基点としてデータを出カじます。 
    xlsApp.Cells(i, 1).Value=QRs4a
    xlsApp.Cells(4, 1).CopyFromRecor南et QRs5 
    xlsApp.Cells(172, 7).Copy恥omRecordset QRs6
    xlsApp.Cells(1, 3i).\員lue = Ri！集＿対象'表見出しになるオーダ種別
      xlsApp.Worksheets(xlSheet.Name).Range("Gl :BE3, G妬9:RE 171").Interior.Color = COLR'見出し色
色
   Ri .MoveNext 
   輪op    '出力先のパスとファイル名を指定します。
    Rfname2 = fPass &''出力￥[02_03_O1」週次目標達成状況一ALL" & QRs4s & ".xlsx"    'ファイル名の後ろに日付を付けて保存もます。 
    xlsApp.DisplayAlerts=False
    xlsApp.Worksheets(sname2)．氏lete 'テンプレシートを削除
    xlsWkb.SaveAs F恥Name：島Rfname2,_ 
    Password:="dc幻n5241竺
    xlsApp.DisplayAlerts=True 
    xlsApp.Quit
   '作業用クエリの削除
   DoCmd.DeleteObject acQuery, Q1.Name 
   DoCmd.DeleteObject acQuery, Q2.Name
   SetQl=Nothing 
   Set Q2=Nothing 
   Set DB=Nothing 
   Set QRs1=Nothing 
   Set QRs2=Nothing 
   Set QRs3=Nothing 
   Set QRs4=Nothing 
   Set QRs5=Nothing 
   Set QRsG=Nothing
   fn2p＝''''
   fname2＝'''' 
   fPass＝''''
   sname2＝''''
   QRs4s=.,,. 
   QRs4a=,..,   'MsgBox "Excelへ出力しました''
End SubSub夏'oExcel 一次代理店個人別0'★★クエリ内の一次代理店名からリストを取得・リスト名と同じ名前のシートの指定したセルにデータを貼付け
★★Dim DB As DAO.Database 
Dim Ri As DAO.Recordset 
Dim R2 As DAO.Recordset 
Dim R3 As DAO.Recordset
Dim QRs1 As DAO.Recordset= 
Dim QRs2 As DAO.恥cOrdset 
Dim QRs3 As DAO.Recordset 
Dim QRs4As DAO.Recordset 
Dim QRs4s As String
Dim QRs4aAs String
Dim QRs5As DAO.Recordset 
Dim QRs6 As DAO.Recordset 
Dim Qi As QueryDef
Dim Q2 As QueryDef
Dim Q3As QueryDef
Dim SQL_Txt As String
Dim SQLesTxt2 As String 
Dim SQL_Txt3 As String 
Dim Pass As String
Dim fname As String'出力先パスとファイル名
Dim fname2 As Strin『出力先パスとファイル名元データシート
Dim Rfname As String '1)ネーム後のファイル名
Dim Rfname2 As String'リネーム後のファイル名元データシート
Dim sname As String'出力先シート名
Dim sname2 As String'出力先シート名元データシート
Dim姐S晒虫bAs Object'ワークブック用オブジェクト変数
Dim xlsApp As Object 
Dim xlSheet As Object 
Dim fn2p As String 
Dim i As Long
Dim COLR As String'セル色
'出力先パスを指定
Pass = "C:YTemp￥O3_ェクスポート￥03＿要望数￥''
 '耕＝=＝舞＝====Access の処理＝========＝井井
 デ→タベースを参照
 Set DB=CurrentDbO '作業用クエリを作成
 SetQl=DB.CreateQueryDef("Q1_"＆動rmat(Now, "yyyymmddhhnnss")) 
 Set Q2=DB.CreateQueryDef("Q2_"&Format(Now, "yyyymmddhhnnss")) 
 Set Q3=DB.CreateQueryDef("Q3_"&Format(Now, "yyyymmddhhnnss"))
 'ファイル名やシート名用の一覧を作成
 SQL_Txt = "SELECT DISTINCT 一次代理店名＿略FROM 20_Ol_Ol 「貼付用元」「個人」''          'ファイル名
用
 SQL_Txt2 = "SELECT DISTINCT 一次＿対象，集＿対象，一次代理店名＿略FROM 20_Ol_Ol 【貼付用元」【個
人」“1抽出用
 SQL_Txt3 = "SELECT DISTINCT 集―対象，RGB FROM 20_Ol_Ol 「貼付用元」「個人」'''シート名用 '一覧をレコードとして扱う
 SetRi=DB.OpenRecordset(SQL_Txt)  'ファイル名用 
 Set R2=DB.OpenRecordset(SQL_Txt2) '抽出用 
 Set R3=DB.OpenRecordset(SQL_Txt3) 'シート名用  '★★＝一＝==＝ファイル単位＝＝一＝一＝＝★★
 Ri .MoveFirst
 Do Until R1.EOF    1#－-----------Excelの処理－----------－#
       '出力先のファイル名を決めます。fPass & Ri!一次代理店名＿略＆".xlsx“とすると'一次代理店別のフ 
ァイルを作成します。      '以下はフオーマットとして使用するファイルなので名称は固定でOK0
      fname = fPass &" [02_03_03] 週次目標達成状況フォーマット＿個人実績．xlsx"         fname=fPass&
Ri！一次代理店名＿略＆''個人実績．xlsx"
      sname =“一次代理店名“'Ri!一次代理店名＿略       '出力先のMs Excelを利用できるように設定します。 
      Set xlsApp=CreateObject("Excel.Application")       'Excel ファイルのパスを指定します。
      Set xlsWkb=xlsApp.Workbooks.Open(_ 
      FileName:=fname，恥adOnly:zFalse_
   血，Pa翻word:=", WriteResPassword:=")  ！女★＝一＝==＝シート単位 ★★ 
  R3.MoveFirst
  Do Until R3.EOF   'クエリの書き換え（SQLのセット）
   Q1.SQL = "SELECT * FROM20玉1 01 【貼付用元」【個人）WHERE 一次代理店名＿略＝'''＆昇1！一次 
代理店名＿略＆ mAND 集＿対象＝''I ＆混掛集＿対象＆111ORDER BY 運営店名“"SELECT *FROM 
03_ 02_ 01 【貼付用元I WHER甘ニプ次代理店名＿略＝'“&R1!一次代理店名＿略＆'''“
   Q2.SQL = "SELECT * FROM 20_01_03 【貼付用元】一次代理店計【個人」WHERE 一次代理店名＿ 
略＝''' &Ri!一次代理店名」略＆堪AND 集―対象＝'“&R3!集―対象＆川''
   Q3.SQLい令ELE奄里昇FROM 20_01_02 【貼付用元】運営店計【個人」w査ERE 一次代理店名＿略＝,,, & 
Ri!一次代理店名＿略＆'''AND 集＿対象＝'“&R3!集―対象＆tll''   Set QR斑＝DB.OpenRecordset(Q1 .Name) 
   Set QRs2=DB.OpenRecordset(Q2.Name) 
   Set QRs3=DB.OpenRecordset(Q3.Name)
   Set QRs4 = DB.OpenRecordset("01_01_03適用日'り
   QRs4s = QRs4('年付》集計期間''） 'ファイル名の後に付ける文字
   QRs4a = QRs4(''適用日最大''）'シートのA1 に入れる文字
   COLR=R3!RGB.Value
   'コピー先の位置取得
   lngCnt=xlsApp.Worksheets.Count    シートコピー
   Set xlSheet＝且sApp.Worksheets(sname) 
   xlSheet.Copy after:=xlsApp.Worksheets(lngCnt)   'シート名変更
   'シートを増やしたのでもう一回数える 
   lngCnt=xlsApp.Worksheets.Count   Set xlSheet=xlsApp.Worksheets(lngCnt) 
   xlSheet.Name=R3！集―対象   'Sheet名を指定します。－「三
   xlsApp.Worksheets(xlS取et.Name)::Select   '入っているデータを削除します。
    xlsApp.Worksheets(xlSheet.Name).Range("A4:CC80，扇4:CC85, A89:CC200").ClearContents    'セル行・列を基点としてデータを出力します。電
    xlsApp・Cells(4, 1).CopyFromRecordset QRs茎＿！一次代理店データ 
    xlsApp.Cells(84, 1).CopyFromRecordset・QRs2 '一次代理店計
    xlsApp.Cells(89, 1).CopyFromRecordset:Q葺網'運営店計 
    xlsApp.Cells(1, 1).Value = QRs4a'日付
    xis抑p.Cells(1, 32).Value ＝肩！集二対象'表見出しになるオーダ種別
    xlsApp・Worksheets(xl跡eet．恥inす・Range("H1:BF3, H81:BF83, H86:BF88").Interi磐． Co加r=COLR 
見出し色二'二   R3.MoveNext
  Loop  '出力先のパスとファイル名を指定します。
  Rfname = Pass &“出力Y個人別￥[02_03_03] 週次目標達成状況（"&Ri！一次代理店名＿略＆り【個人実 
績」''＆QRs4s&".xlsx"  'ファイル名の後ろに日付を付けて保存します。 
  xlsApp.DisplayAlerts=False
  xisApp.Worksheets(sname).Delete 'テンプレシートを削除
  xlsWkb.SaveAs FileName:=Rfname,_ 
  Password:="dcm5241"
  xlsApp.DisplayAlerts=True
  xlsApp.Quit R1.MoveNext 
 Loop DoCmd.DeleteO切ect acQuery, Q1.Name 
 DoCmcLDeleteObject acQuery, Q2.Name 
 DoC血d.DeleteObject acQuery, Q3.Name SetQl=Nothing 
 Set Q2=Nothing 
 Set Q3=Nothingfname=,,,.
fname2＝''''




投稿者 時刻:
登録: 投稿 (Atom)