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＝''''

マクロメニュー

Private Sub Workbook_addinInstall()
    '新たにメニューバーを追加する
    Set Menu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
    'メニューバーの名前
    Menu.Caption = "○ミニマクロ"
   
        'サブメニュー
        Set SubMenu2 = Menu.Controls.Add
        SubMenu2.Caption = "複数ブックを1ブック"
        SubMenu2.OnAction = "確認_複数ブックを1ブックに"

        'サブメニュー
        Set SubMenu3 = Menu.Controls.Add
        SubMenu3.Caption = "複数シートを1シート"
        SubMenu3.OnAction = "確認_複数シートを1シート"
       
        'サブメニュー
        Set SubMenu4 = Menu.Controls.Add
        SubMenu4.Caption = "[●]空白埋め"
        SubMenu4.OnAction = "空白埋め"

        'サブメニュー
        Set SubMenu5 = Menu.Controls.Add
        SubMenu5.Caption = "[？]データ比較"
        SubMenu5.OnAction = "確認_複数列の比較"

        'サブメニュー
        Set SubMenu6 = Menu.Controls.Add
        SubMenu6.Caption = "[→←]結合"
        SubMenu6.OnAction = "文字列を結合する"

        'サブメニュー
        Set SubMenu7 = Menu.Controls.Add
        SubMenu7.Caption = "[↓×]指定列削除"
        SubMenu7.OnAction = "指定列削除"

        'サブメニュー
        Set SubMenu8 = Menu.Controls.Add
        SubMenu8.Caption = "[→×]指定行削除"
        SubMenu8.OnAction = "指定行削除す"
       
        'サブメニュー
        Set SubMenu9 = Menu.Controls.Add
        SubMenu9.Caption = "[↓○]指定列挿入"
        SubMenu9.OnAction = "指定列挿入"

        'サブメニュー
        Set SubMenu10 = Menu.Controls.Add
        SubMenu10.Caption = "[→○]指定行挿入"
        SubMenu10.OnAction = "指定行挿入"

        'サブメニュー
        Set SubMenu11 = Menu.Controls.Add
        SubMenu11.Caption = "[▽]オートフィルタ・分割解除"
        SubMenu11.OnAction = "オートフィルタ等解除"

        'サブメニュー
        Set SubMenu12 = Menu.Controls.Add
        SubMenu12.Caption = "[＄]リンク解除"
        SubMenu12.OnAction = "ハイパーリンク削除"

        'サブメニュー
        Set SubMenu13 = Menu.Controls.Add
        SubMenu13.Caption = "[全]指定列全角化"
        SubMenu13.OnAction = "指定列を全角に"
       
        'サブメニュー
        Set SubMenu14 = Menu.Controls.Add
        SubMenu14.Caption = "[名]名前の定義削除"
        SubMenu14.OnAction = "DeleteDefinedNames"
End Sub

Private Sub Workbook_AddinUninstall()
        'メニューバーを削除
        Application.CommandBars("Worksheet Menu Bar").Controls("○ミニマクロ").Delete
End Sub

名前の定義削除

Public Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Sub DeleteDefinedNames()
Dim beforeReferenceStyle As Variant
beforeReferenceStyle = Application.ReferenceStyle
Dim timerID As Long
timerID = SetTimer(0, 0, 100, AddressOfTimerProc)
    If beforeReferenceStyle = xlR1C1 Then
            Application.ReferenceStyle = xlA1
    Else
            Application.ReferenceStyle = xlR1C1
    End If
    Dim n As Name
        For Each n In ActiveWorkbook.Names
            If Not n.Name Like "*!Print_Area" And _
                Not n.Name Like "*!Print_Titles" Then
                n.Delete
                End If
        Next
    Application.ReferenceStyle = beforeReferenceStyle
    KillTimer 0, timerID
End Sub
Private Function getRandomString(min As Long, max As Long) As String
Dim s As String
Dim i As Long
max = Int(max * Rnd)
    For i = 0 To min + max
        Randomize
        s = s & Chr(65 + Int(26 * Rnd))
    Next
   
    getRandomString = s
   
End Function

End Function

複数ブック系

Dim Rst As VbMsgBoxResult
Sub 確認_複数ブックを1ブックに()
'########################
'#  複数のブックを1つのブックにまとめます
'#
'########################
Rst = MsgBox("このブックと同じフォルダにあるファイルをシートとして追加します。" & vbCrLf & _
"同盟のシートを上書きする場合は「はい」・追加する場合は「いいえ」を押してください。実行しますか？", _
vbYesNoCancel + vbQuestion + vbDefaultButton3, _
"複数ブックを1ブックにまとめる")
        If Rst = vbCancel Then
            Exit Sub
        Else
            複数ブックを1ブックに
        End If
End Sub
Sub 複数ブックを1ブックに()
'########################
'#  複数のブックを1つのブックにまとめます
'#
'########################
Dim mb As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim sws As Worksheet
Dim myfdr As String
Dim fname As String
Dim n As Integer
Dim Pwd As String
Pwd = InputBox("全ファイルに共通のパスワードを設定している場合、" & vbCrLf & _
"【パスワード】を入力してください" & vbCrLf & _
"パスワードなし、異なるパスワードの場合は空欄のままOKを押してください")
    Application.ScreenUpdating = False
        Set mb = ActiveWorkbook '###このコピー先ブックをmbとする
        myfdr = ActiveWorkbook.Path
        fname = Dir(myfdr & "\*.xls*") 'フォルダ内のexcelブックを検索
       
        i = 1
   
    Do Until fname = Empty    'すべて検索
        If fname <> mb.Name Then    'ブック名がこのブックの名前でなければ
            Set wb = Workbooks.Open(Filename:=myfdr & "\" & fname, UpdateLinks:=0, Password:=Pwd)
            'そのブックを開きwbとする
           
            On Error Resume Next
                For Each ws In wb.Worksheets      'コピー元ブックのシートws全部
                    Set cws = mb.Worksheets(ws.Name) 'コピー先ブックmbのシートン名がコピー元wsと同じものをcwsにする
                        If Not cws Is Nothing Then   'コピー元とコピー先に同じシート名があったら
                            If Rst = vbYes Then 'シートの上書きOKなら
                                Application.DisplayAlerts = False
                                mb.Worksheets(ws.Name).Delete     'コピー先のシートを削除
                                Application.DisplayAlerts = True
                            Else
                                wb.Worksheets(ws.Name) = wb.Worksheets(ws.Name) & i 'コピー元ブックのシートwsの名前に数字をつける
                               
                                '名前の定義は消してしまう
                                With wb.Worksheets(ws.Name)
                                DeleteDefinedNames
                                End With
                               
                                i = i + 1
                            End If
                        End If
                    ws.Copy after:=mb.Sheets(mb.Sheets.Count)   'コピー元wsをコピー先mbにコピー、ブックの末尾に置く
                        Next
                        
                         On Error GoTo 0
                         wb.Close savechanges:=False    'コピー元wbを閉じる
                         n = n + 1
        End If
       
        fname = Dir 'フォルダ内の次のExcelブックを検索
        Loop
        Application.ScreenUpdating = True
       
        ActiveWorkbook.Save
        MsgBox n & "件のブックをコピーしました"
End Sub