常連

注目の的

社会貢献

ファイルの移動をしたいのですができません。
ファイルを1度開き、項番を取得して、その項番フォルダーにファイルを移動させたいのですができません。
また、1度目のLoopではファイル名が取得できているのですが、2度目のLoopに入るとFileが空になってしまいます。
```ここに言語を入力
Private Sub CommandButton2_Click()
'Dim fso As FileSystemObject
'Set fso = New FileSystemObject
Set wb = ThisWorkbook
File = Dir(wb.Path & "\エントリーシート*.xlsx")
    Do While File <> ""
        
        '開くExcelファイル
        FilePath = wb.Path & "\エントリーシート\" & File
        Set wbEntry = Workbooks.Open(FilePath)
        Set shEntry = wbEntry.Worksheets(1)
        'エントリーシートの項番
        Entrynum = Format(shEntry.Range("B10"), "000")
        Workbooks(File).Close savechanges:=False
        
        Folder = wb.Path & "\エントリーシート\" & Entrynum
        If Dir(Folder, vbDirectory) <> "" Then
            Name FilePath As Folder & File
            'Call fso.MoveFile(FilePath, Folder & File)
        End If
        File = Dir()
    Loop

End Sub

```

ファイルの移動をしたい

###Excel2010のVBAにて別Bookを開きたい
Windows~~10~~7(32bit)、Excel2010の環境にて
ExcelVBAにて別のBookを開く際にエラーが出て
Bookを開くことが出来ない

追記
Excel2010 Version14.0.7015.1000（32ビット）
開こうとしているBookに関して
・.xlsxファイル(このファイルを生成したExcelのVersionは不明）
・シート数30弱
・マクロ等はしこまれていない

###発生している問題・エラーメッセージ

特定のPCでのみで発生しており
他のPCではエラーは発生せずに正常稼動している

エラーの出ている特定のPCでも10月時点では動作を確認しており
11月中旬あたりで下記のエラーが出るようになった
エラーが発生している特定のPCが手元に無いため
10月～11月中旬ごろの間に、どのような変更があったかは不明

エラー番号:1004
エラー内容:WorkbooksクラスのOpenプロパティを取得できません

###該当のソースコード
```VBA
Dim xlapp As Variant
Set xlapp = CreateObject("excel.application")
xlapp.Visible = False

'ファイルの存在チェック
If Dir(filepath) = "" Then
　　　GoTo Continue
End If

Set xlbooks = xlapp.Workbooks
’ここでエラーが発生
Set work_book = xlbooks.Open(filepath, ReadOnly:=True)
```


###試したこと
下記のことを試しても改善、及び現象の再現はしていない状況です

1.別Verのエクセルが導入された可能性を見越してExcelのVerをチェック
```VBA
If xlapp.Version <> 14# Then
    Dim old_ver As Double
    old_ver = xlapp.Version
    xlapp.Quit
    MsgBox "ExcelVer切り替え:" & old_ver
    Set xlapp = CreateObject("excel.application.14")
    Call m_output_log.output_log("ExcelVer切り替え:" & old_ver)
End If
```

2.開こうとしているBookが他のアプリで使用されている可能性を見越してコピーをとり、コピーしたファイルを開く

3.開こうとしているBookのアクセス権限を変更する

4.負荷テストとしてExcelのプロセスを50個ほど立ち上げる

5.負荷テストとして、別アプリにて物理メモリを食いつぶしてみる

6.CreateObjectを使用せずに下記のコードでのOpen
```VBA
    Set work_book = Workbooks.Open(report_file, ReadOnly:=True)
```
###補足情報
特定のPCで使用しているファイルを別PCにコピーして実行してもエラーが出ない為
特定PCの環境依存の問題かと思われます

拙い文章かつ少ない情報ですが
お心当たりのある方、アドバイスをいただければ幸いです

WorkbooksクラスのOpenプロパティを取得できません

### 前提・実現したいこと

AccessからVBAで雛形となるExcelファイルを使って新規Excelファイルを出力させたいです。

### 発生している問題・エラーメッセージ

出力されたファイルを開くと必ず非表示の状態で開かれます。
そのため、Excel画面の「表示タブ」→「再表示」からブックを表示させないと内容を見ることができません。
再表示させた状態で上書き保存をし、ファイルを閉じてもう一度開くと普通に表示されます。

### 該当のソースコード

標準モジュールに記載して実行
```VBA
Option Compare Database

Public Function test01()
    Dim strReadPath As String, XL As Object, WB As Object, WS As Object
    Set XL = CreateObject("Excel.Application")
    XL.Visible = False
    XL.DisplayAlerts = False
    Set WB = GetObject(CurrentProject.Path & "\test.xlsx") '雛形を取得
    Set WS = WB.Sheets(1)
    WS.Name = "Sheet1"
    WS.Cells(1, 1) = "サンプルテキスト"
    WB.SaveAs FileName:=CurrentProject.Path & "\output.xlsx" '保存
    'XL.Windows("output.xlsx").Visible = True
    'WB.Save
    If Not WB Is Nothing Then WB.Close: Set WB = Nothing
    If Not XL Is Nothing Then XL.Quit: Set XL = Nothing
End Function
```

### 試したこと

全く新しいAccessファイルと、全く新しい雛形ファイルを用意して同じプログラムを実行しましたが同じ症状になりました。
上記ソースコードの下から4行目と5行目、コメント化されている箇所のコメントを解除して実行すると、きちんと表示されるのですが、他のExcelブックを開いた状態で実行するとそこでエラーになります。

### 補足情報（FW/ツールのバージョンなど）

Windows 10 Home 64bit
Microsoft Access 2013
Microsoft Excel 2013

Accessの参照設定：
Visual basic For Applications
Microsoft Access 15.0 Object Library
OLE Automation
Microsoft Office 15.0 Access database engine Object Library
Microsoft Excel 15.0 Object Library

AccessからExcelファイルを作成すると必ず非表示の状態で保存されてしまう

質問させていただきます。

ACCESSからExcelマクロを実行したいと考えており、マクロを保存したBookを開こうとするのですがファイルが見つかりませんという実行時エラー1004が表示されます。

実際に保存しているファイルを手動で開きRunで動かしてみると普通にマクロは実行されました。

「xlms」のファイルを開くときには何が別途コードが必要なのでしょうか？

ご教示いただきますようお願い致します。

```        
Dim EE As Object
Dim wb As Workbook

Set EE = CreateObject("Excel.Application")
            '本番はfalse
        EE.Visible = True
        EE.UserControl = False
        
        Set wb = EE.Workbooks.Open("J:\シミュレート表\シミュレート表_2018\Macro")
        
        EE.Run "シミュ_Macro"
        
        wb.Close
        EE.Quit
        
        Set wb = Nothing
        Set EE = Nothing
end sub

コード
```

ACCESSからExcelを開く

お世話になっております

ExcelのVBA初心者です

Excelファイルに複数枚のシートが存在しており、
全てのシートの印刷設定は完了しています

各シートを１枚ずつにPDFファイルに出力したいと考えています
シート数だけpdfファイルができるようなイメージです。

そこで、以下のようなプログラムを書きました

```vba
Sub sample()

    Dim st As Object
    Dim outPutPath As String
    Dim fileName As String
    Dim waitTime As Variant
    
    outPutPath = '保存先のパス'

    For Each st In Sheets
     st.Activate
     fileName = outPutPath & st.Name
     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileName
     waitTime = Now + TimeValue("0:00:03")
     Application.Wait waitTime
    Next

End Sub
```

問題なく実行され
pdfファイルを出力され続けるのですが、以下のエラーが表示され
途中で処理が落ちてしまいます。
落ちる場所もランダムで、特定のシートで止まっているわけではありません

エラー内容
![イメージ説明](0e3d8f8f4709422e74a06c2816d6cde5.png)

検索してもこのエラーが発生する原因が多いので特定することができませんでした

環境は以下の通りとなります
ご教授頂ければと思います

OS：Windows10
Excelバージョン：Excel2013

---
みなさま、コメントありがとうございます

皆様のコメントやご指摘を対応しておりますが、
現状、エラーは表示されております。

デバッグしたところ、pdfの出力処理、以下の行を実行後にエラーが発生しております。
```vba
st.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileName

```
ループ中ランダムのタイミングで出力されるので、シートに問題が有るわけではないようです。
本処理を実行後、pdfを出力してからエラーが発生する感じです。
ちなみに、出力したファイルに問題はありません。

申し訳ありませんが、ご教授頂ければと思います。

VBAでExcelシートを一枚ずつpdfファイルに出力したい

お世話になっております。

下記参考サイトを元に、コードを作成しました。
> http://officetanaka.net/excel/vba/file/file07.htm
>http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_120.html

```VBA
Private Sub hoge(folderPath As String)
    Dim targetFileName As String 
　　'ファイル名格納①
    targetFileName = Dir(folderPath & "*.xlsx",vbNormal)
    
    Do while targetFileName <> ""
        'openfileは渡されたファイル名を持つファイルを開く処理です。
        Call openFile(targetFileName)

        '新しく開かれたtargetFileNameのBookオブジェクトを格納
        Dim targetWorkBook As WorkBook
        Set targetWorkBook = ActiveWorkBook
        
　　　　'新しく開かれたtargetFileNameの一番目のシートオブジェクトを格納
        Dim targetWorkSheet As WorkSheet
　　　　 Set  targetWorkSheet = targetWorkBook.WorkSheets(1)
        
        'dataEditは渡されたシートオブジェクトのデータにいろいろ設定する
        Call dataEdit(targetWorkSheet)
    　　
         '開かれたファイルを閉じる
         Application.DisplayAlerts = False
         targetWorkBook.Close
         Application.DisplayAlerts = True　
　　　　 
　　　　　'--問題となっているところ。ファイル名格納②--
         targetFileName = Dir()     
    Loop     
    
End Sub
```
説明しやすいように、前提として
folderPath には2件のファイル「ふげ.xlsx」「ほげ.xlsx」があるとします。

参考のサイトの意図する通りに動作するのであれば、
①の処理でふげ.xlsxがtargetFileNameに格納され、
②の処理でほげ.xlsxがtargetFileNameに格納されること思うのですが、
①の処理は上手く動作し、②の処理ではtargetFileNameに""が入っています。

なぜ「ほげ.xlsx」が取れないのでしょうか。
どうぞよろしくお願いいたします。

VBA 指定フォルダの配下にあるファイルをすべて参照する処理について質問

###前提・実現したいこと
access2007で作成したVBAをAccess2016で動作させたい。
ご教授をお願い致します。
###発生している問題・エラーメッセージ

```
Access2007では、ボタンをクリックすると、Excelが表示されて、エクセルのシートに、Accessのデータが登録されるのですが、
Access2016では、全く動作しません。
```

###該当のソースコード
```
Dim AppObj As Object    'Excel.Applicationオブジェクトの宣言
    Dim WBObj As Object     'Excel.Workbookオブジェクトの宣言
    Dim WsObj As Object      'Excel.WorkSheetオブジェクトの宣言
    Dim FilePath As String
    
    FilePath = Application.CurrentProject.Path & "\Sample.xlsx"   'Excelファイルのパスを指定
    '※ Excelファイルが使用するAccessファイルと同じフォルダにある場合の表記
    
    Set AppObj = CreateObject("Excel.Application")  '実行時バインディング
    Set WBObj = AppObj.WorkBooks.Open(FilePath)  'ワークブックを開く
    Set WsObj = WBObj.Worksheets("Sheet1")
    
    AppObj.Visible = True   'Excelアプリケーションを表示する
    
    'ワークシートへの処理
    WsObj.range("A1").value = "Access"
    
    'ワークシートのコピー作成
    WsObj.Copy after:=WsObj
    WBObj.Activesheet.Name = "test"
    
    'Excelを保存して閉じる
    WBObj.Save   'ワークブックを保存する
    WBObj.Close 'ワークブックを閉じる
    AppObj.Quit
End Sub
```

###試したこと
「VBE」（Visual Basic Editor）のメニューから
「ツール」→「参照設定」と選択して、「Microsoft Excel 16.0 Object Library」
にチェックがついているのを確認しました。

マクロ－全てのマクロを有効にする。に設定しています。

###補足情報(言語/FW/ツール等のバージョンなど)
より詳細な情報
Access2013では、上記の設定でよい事が記載されているのですが、Access2016に関する設定を調べたのですが、見つける事が出来ませんでした。

Access2016のVBAでExcel2016ファイル操作を行う方法

###前提・実現したいこと
マクロでGmailを使ってメールを送りたいのですがうまくいきません。

###発生している問題・エラーメッセージ

実行時エラー'2147220973(80040213)':
転送においてサーバーに接続出来ませんでした。
と出ます。
```

Option Explicit
'----- 参照設定 Microsoft CDO for Windows 2XXX Library
Public myCDOMsg As New CDO.Message
Public Const myADDRESS As String _
  = "http://schemas.microsoft.com/cdo/configuration/"

Dim gyo As Long
Dim gyo2 As Long
Dim filecount As Long
Dim sheetcount As Long
Dim unmatch As Long
Dim erfilecount As Long


'ボタンを押したとき
Sub FolderSelect()
    'ThisWorkbook.Worksheets(1).Range("A6:C3005").ClearContents
    'ThisWorkbook.Worksheets(2).Range("B1:BE3005").ClearContents
    Dim folderpass As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            folderpass = .SelectedItems(1)
        Else
            ThisWorkbook.Worksheets(1).Range("B3").Value = "キャンセルしました。"
            Exit Sub
        End If
    End With
    
    filecount = 0
    sheetcount = 0
    unmatch = 0
    erfilecount = 0
    gyo = 6
    gyo2 = 2
   
    
    ThisWorkbook.Worksheets(1).Range("B2").Value = "処理中"
    
    Call FileSearch(folderpass, "*.csv")
   Dim dateupdate As String
   dateupdate = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日更新"
   'ThisWorkbook.Worksheets(2).Range("A1").Value = dateupdate
   'ThisWorkbook.Worksheets(2).Name = dateupdate '
   ThisWorkbook.Worksheets(1).Range("B2").Value = "完了"
   ThisWorkbook.Worksheets(2).Activate
End Sub
'ファイル検索
Sub FileSearch(Path As String, Target As String)
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSearch(Folder.Path, Target)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If File.Name Like Target Then
            filecount = filecount + 1
            ThisWorkbook.Worksheets(1).Cells(gyo, 1) = File.Name
            ThisWorkbook.Worksheets(1).Cells(gyo, 2) = File.Path
            Call ParCopy(File.Path)
            gyo = gyo + 1
        End If
    ThisWorkbook.Worksheets(1).Range("B3").Value = filecount & "個のファイルが見つかりました。"
    Next File
End Sub
''一覧出力
Sub ParCopy(Path As String)


    Dim openbook As Workbook
    Dim openbooksheet As Worksheet
    Dim lp As Long
    Dim el As Long
    Dim br As String
    'オ
    Dim c As Range, Target As Range
    Dim LastRow As Long
    '縦軸(マクロ側シート数用)
    lp = 2
    '横軸(データ側ループ管理用)
    el = 3

    
    
    Application.ScreenUpdating = False

    On Error GoTo myError
    Set openbook = Application.Workbooks.Open(Path)


 'シートを格納
 
        Set openbooksheet = openbook.Worksheets(1)
        openbooksheet.Unprotect
        
 'シート数でのループ
      Do Until lp = 28
    '各シート毎のループ
        Do Until ThisWorkbook.Worksheets(lp).Cells(1, el) = ""
        
          br = ThisWorkbook.Worksheets(lp).Cells(2, el)
          
          'オートフィルタ用のアクティブ化
          openbooksheet.Activate
          
          Selection.AutoFilter
          openbooksheet.Range("A1").AutoFilter Field:=8, Criteria1:=br
          
          '最終行の指定
          LastRow = 291826
          
        'マクロ側へのコピペ
          openbooksheet.Range("J2:J" & LastRow).Copy ThisWorkbook.Worksheets(lp).Range(ThisWorkbook.Worksheets(lp).Cells(3, el), ThisWorkbook.Worksheets(lp).Cells(3, el))
          openbooksheet.Range("A1").AutoFilter
    
      
          el = el + 1
    
        Loop
         'シート側変数の初期化
         el = 3
         
         lp = lp + 1
      Loop
    
     
       
  
  
    openbook.Close False
    
    
    Application.ScreenUpdating = True
    Call test02
    Exit Sub
    
myError:
    MsgBox Err.Description
    ThisWorkbook.Worksheets(1).Cells(gyo, 3) = "エラー発生"
    erfilecount = erfilecount + 1
    Application.ScreenUpdating = True
End Sub

 'シート毎保存部分
      
      Sub test02()
      

    
         Dim wb1 As Workbook
         Dim i As Long
         Dim s As Long
         Dim mo As String
  
         Set wb1 = ActiveWorkbook
         s = wb1.Sheets.Count
         s = s - 1
         
         
         
          For i = 2 To s
          
             mo = ThisWorkbook.Worksheets(28).Cells(i, 2)
             
             Workbooks.Add.SaveAs Filename:="C:\Users\hogehoge\Desktop\集計\" & mo & ".xls"
             wb1.Worksheets(i).Copy before:=Workbooks(mo & ".xls").Worksheets(1)
             Workbooks(mo & ".xls").Worksheets(1).Name = mo
          
          Next i
      Call SendMail
      End Sub



Sub SendMail()

  With myCDOMsg
    .To = "受信者 <hogehoge@docomo.ne.jp>" '----- 宛先
    '表示名を設定しない場合は<>の中だけでよい。
    '.To = "aaa@aaa.com;bbb@bbb.com"
   ' .CC = "ccc@ccc.com" '----- CC
    .From = "送信者 <test@gmail.com>" '----- 送信者
    .Subject = "テストの件" '----- 件名
    .TextBody = _
      " テストです。" & vbCrLf & _
      " テストです。" & vbCrLf & _
      " テストです。" & vbCrLf & _
      " テストです。" '----- 本文
   

    With .Configuration.Fields
      .Item(myADDRESS & "sendusing") = 2
      '----- SMTPサーバーを設定
      .Item(myADDRESS & "smtpserver") = "smtp.gmail.com"
      .Item(myADDRESS & "smtpserverport") = 587
      .Item(myADDRESS & "smtpauthenticate") = 1
      .Item(myADDRESS & "smtpusessl") = True
      .Item(myADDRESS & "sendusername") = "ID"
      .Item(myADDRESS & "sendpassword") = "パスワード"
      .Update
    End With

    .Send
  End With

End Sub



```

###試したこと
ポートを変えたり、ブラウザ側でセキュリティレベルを下げたりしてみたのですがうまくいきませんでした。

###補足情報(言語/FW/ツール等のバージョンなど)
WIN10/Excel2013でやっています
皆様のお力をお貸しください。
よろしくお願いします。

マクロでGmailを送りたい 

ACCESSファイルからEXCELファイル（ACCESSファイルと同じフォルダ内にある、[aaa.xlsx]）
のデータを取得する際に次のようなコードを書きました。

```ここに言語を入力
---------------------------------------
Sub Test1()　　　　'(エクセルの参照設定はしていません)

Dim obj As Object

Set obj = CreateObject("Excel.Application")
obj.Application.Visible = True
Dim str1 As String

Dim i As Integer
Dim j As Integer

str1 = CurrentProject.Path & "\aaa.xlsx"

With obj.Workbooks.Open(str1)

	For i = 1 To 3

   		For j = 1 To 3
    	        Debug.Print .Worksheets("Sheet1").Cells(i, j).Value
    	   Next j

	Next i

End With

obj.Quit
Set obj = Nothing

End Sub

----------------------------------------------
次に、　エクセルの参照設定をしたうえで、
次のようなコードを書きました。

Sub Test2()

Dim str1 As String

Dim i As Integer
Dim j As Integer

str1 = CurrentProject.Path & "\aaa.xlsx"


With Workbooks.Open(str1)

	For i = 1 To 3

    	For j = 1 To 3
    	Debug.Print .Worksheets("Sheet1").Cells(i, j).Value
   		Next j

	Next i

End With

End Sub

------------------------------------------------
```
Test2ではEXCELアプリケーションのオブジェクト（CreateObject）は作っていませんが、
プログラムは作動します。
ただ、バックグラウンドで生成された？EXCELアプリケーションが残ったままに
なってしまいました。

質問1

Test2で生成されたEXCELアプリケーションをきちんと消去する方法はありますか？

End with　の次に「Excel.Application.Quit」を入れて試しましたが、消えませんでした。

質問2

(質問1に関連しますが)Test2のようなコードの書き方はよくないのでしょうか？
CreateObjectしなくても済むなら。。。。と思ったのですが。

最初に思ったのは、CreateObjectしないから、オブジェクトを終わらせる処理
(Set *** = NothingとかExcel.Application.Quitとか)を入れなくて済む
のではないかと考えましたが、CreateObjectしてもしなくても
EXCELのプロセスが発生するのならば、CreateObjectをして、そのオブジェクトを
Quitするべき、なのでしょうか？(ただ、Test2でも動くんですよね。。)

何かとんちんかんなことを質問しているのかもしれませんが、よろしくお願いします。