[[20201126171413]]　『Excel６４ビット変更後のVBAコンパイルエラー』（マツ）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『Excel６４ビット変更後のVBAコンパイルエラー』（マツ）

Office365バージョンアップ(64ビット)に伴い32ビットで作成したVBAでコンパイルエラー（型が一致しません）が発生します。詳しい方ご教示願います。

 **************************************************
' 機能      ：取込処理(対象フォルダにExcelファイルがあればリストアップする)

' 引数 ：指定されたディレクトリ（String）
' 戻値 ：なし
' **************************************************
Public Sub GetFiles(instrDir As String)
On Error GoTo Err_GetFiles

    ' 引数のフォルダ以下のファイル名を返す
    Dim i As LongPtr               ' ループカウンタ
    Dim j As LongPtr               ' ループカウンタ
    Dim aryDir() As String      ' ディレクトリ群
    Dim aryFile() As String     ' ファイル群
    Dim strName As String       ' ファイル名
    Dim aryRet() As String      ' 戻り値用配列
    Dim intCount As Integer     ' 取得件数
    Dim swap As String          ' 並べ替え用

    Err.Clear   ' エラーを初期化
    ErrMSG = ""
    intCount = 0

    i = 0
    ReDim aryDir(i)
    aryDir(i) = instrDir ' フォルダをここで指定
    ' まず指定フォルダ以下の全サブフォルダを取得して配列aryDirへ
    Do
        ' 最後の「\」が無ければ付与
        If Right(aryDir(i), 1) <> "\" Then
            strName = Dir(aryDir(i) & "\", vbDirectory)
        End If
        Do While strName <> ""
            If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then
                If strName <> "." And strName <> ".." Then
                    ReDim Preserve aryDir(UBound(aryDir) + 1)
                    aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName
                End If
            End If
            strName = Dir()
        Loop
        i = i + 1
        If i > UBound(aryDir) Then
            Exit Do
        End If
    Loop

    ' 配列aryDirの全フォルダについてファイルを取得し、配列aryFileへ
    ReDim aryFile(0)
    For i = 0 To UBound(aryDir)
        strName = Dir(aryDir(i) & "\", vbNormal)
'        strName = Dir(aryDir(i) & "\", vbNormal + vbHidden + vbReadOnly + vbSystem)
        Do While strName <> ""
            If Left(strName, 2) <> "~$" Then
                If aryFile(0) <> "" Then
                    ReDim Preserve aryFile(UBound(aryFile) + 1)
                End If
                '2015/09/04 対象ファイルが存在しない時の不具合対応　------------------->
                'If (Right(strName, 3) = "xls" Or Right(strName, 4) = "xlsx") Then
                If (LCase(Right(strName, 3)) = "xls" Or LCase(Right(strName, 4)) = "xlsx") Then
                '2015/09/04 対象ファイルが存在しない時の不具合対応　------------------->
                    ' 戻り値用の配列に入れる
                    ReDim Preserve aryRet(intCount)
                    aryRet(intCount) = aryDir(i) & "\" & strName
                    intCount = intCount + 1
                End If
            End If
            strName = Dir()
        Loop
    Next

    '2015/09/04 対象ファイルが存在しない時の不具合対応　------------------->
'    If UBound(aryDir) > 0 Then
'        ' 配列(ファイル名)をソートする
'        For i = 0 To UBound(aryDir)       ''ソート開始
'            For j = UBound(aryDir) To i Step -1
'                If aryRet(i) > aryRet(j) Then
'                    swap = aryRet(i)
'                    aryRet(i) = aryRet(j)
'                    aryRet(j) = swap
'                End If
'            Next j
'        Next i
'    End If

    'ファイルが存在する場合
    If intCount > 0 Then
        ' 配列(ファイル名)をソートする
        For i = 0 To UBound(aryRet)       ''ソート開始
            For j = UBound(aryRet) To i Step -1
                If aryRet(i) > aryRet(j) Then
                    swap = aryRet(i)
                    aryRet(i) = aryRet(j)
                    aryRet(j) = swap
                End If
            Next j
        Next i
    End If
    '2015/09/04 対象ファイルが存在しない時の不具合対応　------------------->

    ' 0件時
    If Sgn(aryRet) = 0 Then
'        InFileName = aryRet
        InFileCount = 0
        Exit Sub
    Else
        ' 配列をセットして終了
        InFileName = aryRet
'        InFileCount = intCount - 1
        InFileCount = intCount
        Exit Sub
    End If

Err_GetFiles:

    ErrMSG = CStr(Err.Number) & ":" & Error
End Sub

＜ 使用 Excel：Office365、使用 OS：Windows10 ＞

---

 >VBAでコンパイルエラー（型が一致しません）
 どの部分でエラーになるか記述しないと回答が付かないのでは。
（VAB） 2020/11/26(木) 19:39

---

関係しそうなのはこの2つですね。

    Dim i As LongPtr               ' ループカウンタ
    Dim j As LongPtr               ' ループカウンタ
なぜLongにしていないのか気になります。

もし上限を超えるファイル数を想定しているなら、他の変数の型も変えないといけないはず。

（通りすがりの） 2020/11/27(金) 09:32

---

 >なぜLongにしていないのか気になります。
 Microsoft ドキュメントの中に
『LongPtr は、32 ビット環境では Long に変換され、64 ビット環境では 
 LongLong に変換されるので、実際のデータ型ではありません。
 LongPtr を使用すると、32 ビット環境と 64 ビット環境の両方で実行できる
 移植性のあるコードを作成できます。 ポインターおよびハンドラーには    LongPtr を使用してください。』
 という記事があります。
（tori） 2020/11/27(金) 11:07

---

エラー部分を補足します。
←箇所でコンパイルエラーが発生します。
詳しい方ご教示願います。

************************************************

' 機能 ：?@取込処理(対象フォルダにExcelファイルがあればリストアップする)
' 引数 ：指定されたディレクトリ（String）
' 戻値 ：なし
' **************************************************
Public Sub GetFiles(instrDir As String)
On Error GoTo Err_GetFiles

    ' 引数のフォルダ以下のファイル名を返す
    Dim i As LongPtr               ' ループカウンタ
    Dim j As LongPtr               ' ループカウンタ
    Dim aryDir() As String      ' ディレクトリ群
    Dim aryFile() As String     ' ファイル群
    Dim strName As String       ' ファイル名
    Dim aryRet() As String      ' 戻り値用配列
    Dim intCount As Integer     ' 取得件数
    Dim swap As String          ' 並べ替え用

    Err.Clear   ' エラーを初期化
    ErrMSG = ""
    intCount = 0

    i = 0
    ReDim aryDir(i)←この箇所でコンパイルエラーが発生する。
    aryDir(i) = instrDir ' フォルダをここで指定
    ' まず指定フォルダ以下の全サブフォルダを取得して配列aryDirへ
    Do
        ' 最後の「\」が無ければ付与
        If Right(aryDir(i), 1) <> "\" Then
            strName = Dir(aryDir(i) & "\", vbDirectory)
        End If
        Do While strName <> ""
            If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then
                If strName <> "." And strName <> ".." Then
                    ReDim Preserve aryDir(UBound(aryDir) + 1)
                    aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName
                End If
            End If
            strName = Dir()
        Loop
        i = i + 1
        If i > UBound(aryDir) Then
            Exit Do
        End If
    Loop

    ' 配列aryDirの全フォルダについてファイルを取得し、配列aryFileへ
    ReDim aryFile(0)
    For i = 0 To UBound(aryDir)
        strName = Dir(aryDir(i) & "\", vbNormal)
'        strName = Dir(aryDir(i) & "\", vbNormal + vbHidden + vbReadOnly + vbSystem)
        Do While strName <> ""
            If Left(strName, 2) <> "~$" Then
                If aryFile(0) <> "" Then
                    ReDim Preserve aryFile(UBound(aryFile) + 1)
                End If
                対象ファイルが存在しない時の不具合対応　------------------->
                'If (Right(strName, 3) = "xls" Or Right(strName, 4) = "xlsx") Then
                If (LCase(Right(strName, 3)) = "xls" Or LCase(Right(strName, 4)) = "xlsx") Then
                '対象ファイルが存在しない時の不具合対応　------------------->
                    ' 戻り値用の配列に入れる
                    ReDim Preserve aryRet(intCount)
                    aryRet(intCount) = aryDir(i) & "\" & strName
                    intCount = intCount + 1
                End If
            End If
            strName = Dir()
        Loop
    Next

    '対象ファイルが存在しない時の不具合対応　------------------->
'    If UBound(aryDir) > 0 Then
'        ' 配列(ファイル名)をソートする
'        For i = 0 To UBound(aryDir)       ''ソート開始
'            For j = UBound(aryDir) To i Step -1
'                If aryRet(i) > aryRet(j) Then
'                    swap = aryRet(i)
'                    aryRet(i) = aryRet(j)
'                    aryRet(j) = swap
'                End If
'            Next j
'        Next i
'    End If

    'ファイルが存在する場合
    If intCount > 0 Then
        ' 配列(ファイル名)をソートする
        For i = 0 To UBound(aryRet)       ''ソート開始
            For j = UBound(aryRet) To i Step -1
                If aryRet(i) > aryRet(j) Then
                    swap = aryRet(i)
                    aryRet(i) = aryRet(j)
                    aryRet(j) = swap
                End If
            Next j
        Next i
    End If
    '対象ファイルが存在しない時の不具合対応　------------------->

    ' 0件時
    If Sgn(aryRet) = 0 Then
'        InFileName = aryRet
        InFileCount = 0
        Exit Sub
    Else
        ' 配列をセットして終了
        InFileName = aryRet
'        InFileCount = intCount - 1
        InFileCount = intCount
        Exit Sub
    End If

Err_GetFiles:

    ErrMSG = CStr(Err.Number) & ":" & Error
End Sub
（マツ） 2020/11/27(金) 11:52

---

ポインターおよびハンドラーに使うわけでもないので、
Dim i As Long
で良いのでは？

なお、Option Explicitを使った方がよいですよ。
未宣言の変数がいくつかあります。バグの元です。
VBEのオプション設定により、（今後作成するモジュールに対して）、
Option Explicitを自動挿入させることができます。
（γ） 2020/11/27(金) 13:10

---

＞tori さん
そういう言語仕様の話ではなくて、ソースコードを見る限りLongで十分なのに、なぜLongPtrを使っているのか？です。

考えようによっては、膨大なファイル数を想定しておりLongでは容量が足りないからLongPtrを使ったとも読み取れます。

つまりLongPtrをLongにすれば良のか、それともコード全体をLongLongに耐えられるように直さないといけない話なのか。という要件の確認です。

この様子だと、そこまで明確な要件は決まっていない雰囲気なので、

    Dim i As LongPtr               ' ループカウンタ
    Dim j As LongPtr               ' ループカウンタ
を
    Dim i As Long
    Dim j As Long
に変えるので十分だと思います。

APIの64bit対応で、気軽にLongをLongPtrに変えたのが原因でハマってしまった。と見受けられます。
（通りすがりの） 2020/11/27(金) 14:48

---

回答ありがとうございます。
32ビットで作成したマクロを64ビットで使用するため、LongをLongPtrに変更しました。

Dim i As LongPtr→Dim i As Long ' ループカウンタ
Dim j As LongPtr→Dim j As Long ' ループカウンタ
に戻して実行するとエラーメッセージが表示します。

Option Explicit

' ***** API *****(Windowsのワークフォルダ取得用)
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _

                                        (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
                                        (lpBrowseInfo As BROWSEINFO) As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
                                        (ByVal nBufferLength As LongPtr, ByVal lpBuffer As String) As LongPtr
Private Const MAX_PATH As Integer = 260

Public Sub GetFiles(instrDir As String)

 On Error GoTo Err_GetFiles 

    ' 引数のフォルダ以下のファイル名を返す
    Dim i As Long               ' ループカウンタ
    Dim j As Long               ' ループカウンタ
    Dim aryDir() As String      ' ディレクトリ群
    Dim aryFile() As String     ' ファイル群
    Dim strName As String       ' ファイル名
    Dim aryRet() As String      ' 戻り値用配列
    Dim intCount As Integer     ' 取得件数
    Dim swap As String          ' 並べ替え用

    Err.Clear   ' エラーを初期化
    ErrMSG = ""
    intCount = 0

    i = 0
    ReDim aryDir(i)←この箇所でコンパイルエラーが発生する。
    aryDir(i) = instrDir ' フォルダをここで指定
    ' まず指定フォルダ以下の全サブフォルダを取得して配列aryDirへ
    Do
        ' 最後の「\」が無ければ付与
        If Right(aryDir(i), 1) <> "\" Then
            strName = Dir(aryDir(i) & "\", vbDirectory)
        End If
        Do While strName <> ""
            If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then
                If strName <> "." And strName <> ".." Then
                    ReDim Preserve aryDir(UBound(aryDir) + 1)
                    aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName
                End If
            End If
            strName = Dir()
        Loop
        i = i + 1
        If i > UBound(aryDir) Then
            Exit Do
        End If
    Loop

    ' 配列aryDirの全フォルダについてファイルを取得し、配列aryFileへ
    ReDim aryFile(0)
    For i = 0 To UBound(aryDir)
        strName = Dir(aryDir(i) & "\", vbNormal)
'        strName = Dir(aryDir(i) & "\", vbNormal + vbHidden + vbReadOnly + vbSystem)
        Do While strName <> ""
            If Left(strName, 2) <> "~$" Then
                If aryFile(0) <> "" Then
                    ReDim Preserve aryFile(UBound(aryFile) + 1)
                End If
                対象ファイルが存在しない時の不具合対応　------------------->
                'If (Right(strName, 3) = "xls" Or Right(strName, 4) = "xlsx") Then
                If (LCase(Right(strName, 3)) = "xls" Or LCase(Right(strName, 4)) = "xlsx") Then
                '対象ファイルが存在しない時の不具合対応　------------------->
                    ' 戻り値用の配列に入れる
                    ReDim Preserve aryRet(intCount)
                    aryRet(intCount) = aryDir(i) & "\" & strName
                    intCount = intCount + 1
                End If
            End If
            strName = Dir()
        Loop
    Next

    '対象ファイルが存在しない時の不具合対応　------------------->
'    If UBound(aryDir) > 0 Then
'        ' 配列(ファイル名)をソートする
'        For i = 0 To UBound(aryDir)       ''ソート開始
'            For j = UBound(aryDir) To i Step -1
'                If aryRet(i) > aryRet(j) Then
'                    swap = aryRet(i)
'                    aryRet(i) = aryRet(j)
'                    aryRet(j) = swap
'                End If
'            Next j
'        Next i
'    End If

    'ファイルが存在する場合
    If intCount > 0 Then
        ' 配列(ファイル名)をソートする
        For i = 0 To UBound(aryRet)       ''ソート開始
            For j = UBound(aryRet) To i Step -1
                If aryRet(i) > aryRet(j) Then
                    swap = aryRet(i)
                    aryRet(i) = aryRet(j)
                    aryRet(j) = swap
                End If
            Next j
        Next i
    End If
    '対象ファイルが存在しない時の不具合対応　------------------->

    ' 0件時
    If Sgn(aryRet) = 0 Then
'        InFileName = aryRet
        InFileCount = 0
        Exit Sub
    Else
        ' 配列をセットして終了
        InFileName = aryRet
'        InFileCount = intCount - 1
        InFileCount = intCount
        Exit Sub
    End If

Err_GetFiles:

    ErrMSG = CStr(Err.Number) & ":" & Error
End Sub

（マツ） 2020/11/27(金) 16:40

---

「どこで」エラーが出るのですか？　追記されたAPIはどこでも使用されていないみたいですが。

（通りすがりの） 2020/11/27(金) 16:50

---

全てのコードを記載します。
マクロ実行で以下のポップアップウィンドウが表示します。
「対象ファイルが存在しません。51:内部エラーです。」
←の箇所のメッセージが表示すると思われます。
32ビットで作成したマクロが64ビットで動作できず困っています。
詳しい方ご教示願います。

Option Explicit
' **************************************************
' 概要　　　：指定フォルダ以下のExcelファイルを
' 対象に集計を行う
' **************************************************

' ***** API *****(Windowsのワークフォルダ取得用)
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _

                                        (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
                                        (lpBrowseInfo As BROWSEINFO) As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
                                        (ByVal nBufferLength As LongPtr, ByVal lpBuffer As String) As LongPtr
Private Const MAX_PATH As Integer = 260

' パブリック変数
Public InFileName() As String ' 画面から引き継いだフォルダ情報
Public skipFlg As Boolean ' 出力があるか？

' ■■■入力/出力フォーマット変更時はここを変えてください■■■
' 入力フォーマット
Private Const IN_BADNO As String = "A7" '
Private Const IN_ISSUE_DATE As String = "F7" '
Private Const IN_ORDER As String = "L7" '
Private Const IN_ORDER_SOURCE As String = "A9" '
Private Const IN_SUBJECT As String = "L9" '
Private Const IN_MODELS As String = "AB9" '
Private Const IN_DECENES As String = "AH9" '

' 不良発見工程はピンポイントで設定 ■
'''''''''' 1行目
Private Const IN_PROD_OUT As String = "W4" '
Private Const IN_PRO_IN As String = "AC4" '
Private Const IN_UNIT As String = "AI4" '
'''''''''' 2行目
Private Const IN_BORD_INSP As String = "W5" '
Private Const IN_MARKING_CONF As String = "AC5" '
Private Const IN_HD_TEST As String = "AI5" '
'''''''''' 3行目
Private Const IN_SYSTEM_TEST As String = "W6" '
Private Const IN_SHIPPING_INSP As String = "AC6" '
Private Const IN_FIELD_TEST As String = "AI6" '

' 入力明細行
Private Const IN_NO As String = "A" '
Private Const IN_SPOILAGE As String = "B" '
Private Const IN_BURDEN As String = "D" '
Private Const IN_PHENOMENON As String = "B" '
Private Const IN_NUM_DEFECTS As String = "D" '
Private Const IN_PRODUCT As String = "G" '
Private Const IN_TROUBLE_CONTENT As String = "P" '
Private Const IN_DEADLINE As String = "AJ" '
Private Const IN_COR_NECECE As String = "AM" '
Private Const IN_TREATMENT As String = "AP" '
Private Const IN_TREATMENT_DAY As String = "BA" '
Private Const IN_RELAP_PREVENT As String = "BD" '
Private Const IN_TC_RESULT As String = "BO" '
Private Const IN_DATE_CONFIR As String = "BX" '
Private Const IN_CONFIR_PERSON As String = "CA" '
Private Const IN_TREATMENT_SECTION As String = "AY3" '

' その他定数
Public Const DEF_FILENAME As String = _

                "データ集計結果_%1%.xlsx"         ' 
Private Const MB_OK = &H0                                   ' 
Private Const MB_TOPMOST = &H40000                          ' 
Private Const GWL_STYLE = (-16)                             ' 
Private Const WS_SYSMENU = &H80000                          ' 
Private Const SEP As String = "/"                           ' 
Private Const TARGET_SHEET As String = "ﾌｫｰﾏｯﾄ"             ' 
Private Const OUT_SHEET_NAME As String = "sheet1"           ' 
Private Const NEW_SHEET As Integer = 1                      ' 
Private Const COL_CHAR As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

' メッセージ定数(タイトル)
Public Const T01 As String = "データ集計ツール" ' メッセージボックスタイトル
Public Const T02 As String = "保存先の指定" ' 保存ダイアログタイトル
Public Const T03 As String = "終了します" ' 終了ダイアログタイトル

' メッセージ定数(メッセージ)
Public Const I01 As String = "集計を実行しますか？"
Public Const I03 As String = "集計処理が終了しました。" & vbCrLf & "集計結果を表示し処理を終了します。"

' メッセージ定数(エラー)
Public Const E01 As String = "指定されたフォルダが存在しません。"
Public Const E02 As String = "ファイルがオープンできません。"
Public Const E03 As String = "例外が発生しました" & vbCrLf & vbCrLf
Public Const E04 As String = "対象のファイルが存在しません。"←このエラーメッセージが表示します。

' ブラウザインフォ構造体(ダイアログ指定で使用)
Public Type BROWSEINFO

    hOwner As LongPtr
    pidlRoot As LongPtr
    pszDisplayName As String
    lpszTitle As String
    ulFlags As LongPtr
    lpfn As LongPtr
    lParam As LongPtr
    iImage As LongPtr
End Type

'''''''''''''''''''''''''''''''''''''''''''''''''''''' ここからプロパティ
' プロパティ変数
Private pInFileCount As Integer ' 入力ファイル数プロパティ（フォーム→コモン）
Private pErrMSG As String ' エラーメッセージプロパティ（コモン→フォーム）

' **************************************************
' 機能 ：入力ファイル数プロパティ
' ' **************************************************
Public Property Let InFileCount(ByRef In_InFileCount As Integer)

    pInFileCount = In_InFileCount
End Property
Public Property Get InFileCount() As Integer
    InFileCount = pInFileCount
End Property

' **************************************************
' 機能 ：エラーメッセージプロパティ
' ' **************************************************
Public Property Let ErrMSG(ByRef In_ErrMSG As String)

    pErrMSG = In_ErrMSG
End Property
Public Property Get ErrMSG() As String
    ErrMSG = pErrMSG
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''' ここからイベント
' **************************************************
' 機能      ：フォルダの選択ボタン押下後処理
' ' **************************************************
Public Function GetFolder(Optional Msg As String) As String
On Error GoTo Err_GetFolder

    Dim bInfo As BROWSEINFO, pPath As String
    Dim R As LongPtr, X As LongPtr, pos As Integer

    Err.Clear   ' エラーを初期化
    bInfo.pidlRoot = 0&

    If IsMissing(Msg) Then
        bInfo.lpszTitle = "取込フォルダの選択"
    Else
        bInfo.lpszTitle = Msg
    End If
    bInfo.ulFlags = &H1
    X = SHBrowseForFolder(bInfo)
    pPath = Space$(512)
    R = SHGetPathFromIDList(ByVal X, ByVal pPath)
    If R Then
        pos = InStr(pPath, Chr$(0))
        GetFolder = Left(pPath, pos - 1)
    Else
        GetFolder = ""
    End If

    Exit Function
Err_GetFolder:
    ErrMSG = CStr(Err.Number) & ":" & Error
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''' ここからメイン処理
' **************************************************
' 機能      ：?@取込処理(対象フォルダにExcelファイルがあればリストアップする)
' ' 引数      ：指定されたディレクトリ（String）
' 戻値      ：なし
' **************************************************
Public Sub GetFiles(instrDir As String)
On Error GoTo Err_GetFiles

    ' 引数のフォルダ以下のファイル名を返す
    Dim i As Long               ' ループカウンタ
    Dim j As Long                ' ループカウンタ
    Dim aryDir() As String      ' ディレクトリ群
    Dim aryFile() As String     ' ファイル群
    Dim strName As String       ' ファイル名
    Dim aryRet() As String      ' 戻り値用配列
    Dim intCount As Integer     ' 取得件数
    Dim swap As String          ' 並べ替え用

    Err.Clear   ' エラーを初期化
    ErrMSG = ""
    intCount = 0

    i = 0
    ReDim aryDir(i)
    aryDir(i) = instrDir ' フォルダをここで指定
    ' まず指定フォルダ以下の全サブフォルダを取得して配列aryDirへ
    Do
        ' 最後の「\」が無ければ付与
        If Right(aryDir(i), 1) <> "\" Then
            strName = Dir(aryDir(i) & "\", vbDirectory)
        End If
        Do While strName <> ""
            If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then
                If strName <> "." And strName <> ".." Then
                    ReDim Preserve aryDir(UBound(aryDir) + 1)
                    aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName
                End If
            End If
            strName = Dir()
        Loop
        i = i + 1
        If i > UBound(aryDir) Then
            Exit Do
        End If
    Loop

    ' 配列aryDirの全フォルダについてファイルを取得し、配列aryFileへ
    ReDim aryFile(0)
    For i = 0 To UBound(aryDir)
        strName = Dir(aryDir(i) & "\", vbNormal)
'        strName = Dir(aryDir(i) & "\", vbNormal + vbHidden + vbReadOnly + vbSystem)
        Do While strName <> ""
            If Left(strName, 2) <> "~$" Then
                If aryFile(0) <> "" Then
                    ReDim Preserve aryFile(UBound(aryFile) + 1)
                End If
                '2015/09/04 対象ファイルが存在しない時の不具合対応　------------------->
                'If (Right(strName, 3) = "xls" Or Right(strName, 4) = "xlsx") Then
                If (LCase(Right(strName, 3)) = "xls" Or LCase(Right(strName, 4)) = "xlsx") Then
                '2015/09/04 対象ファイルが存在しない時の不具合対応　------------------->
                    ' 戻り値用の配列に入れる
                    ReDim Preserve aryRet(intCount)
                    aryRet(intCount) = aryDir(i) & "\" & strName
                    intCount = intCount + 1
                End If
            End If
            strName = Dir()
        Loop
    Next

    対象ファイルが存在しない時の不具合対応　------------------->
'    If UBound(aryDir) > 0 Then
'        ' 配列(ファイル名)をソートする
'        For i = 0 To UBound(aryDir)       ''ソート開始
'            For j = UBound(aryDir) To i Step -1
'                If aryRet(i) > aryRet(j) Then
'                    swap = aryRet(i)
'                    aryRet(i) = aryRet(j)
'                    aryRet(j) = swap
'                End If
'            Next j
'        Next i
'    End If

    'ファイルが存在する場合
    If intCount > 0 Then
        ' 配列(ファイル名)をソートする
        For i = 0 To UBound(aryRet)       ''ソート開始
            For j = UBound(aryRet) To i Step -1
                If aryRet(i) > aryRet(j) Then
                    swap = aryRet(i)
                    aryRet(i) = aryRet(j)
                    aryRet(j) = swap
                End If
            Next j
        Next i
    End If
    対象ファイルが存在しない時の不具合対応　------------------->

    ' 0件時
    If Sgn(aryRet) = 0 Then
'        InFileName = aryRet
        InFileCount = 0
        Exit Sub
    Else
        ' 配列をセットして終了
        InFileName = aryRet
'        InFileCount = intCount - 1
        InFileCount = intCount
        Exit Sub
    End If

Err_GetFiles:

    ErrMSG = CStr(Err.Number) & ":" & Error
End Sub

' **************************************************
' 機能名：?A出力処理
' 機能概要 ：定数で設定されたセルの内容をExcel形式で出力する
' 引数 ：なし
' 戻値 ：作成したテンポラリファイル名
' **************************************************
Public Function MakeExcel() As String
On Error GoTo Err_MakeExcel

    ' 変数宣言
    Dim TempName As String              ' テンポラリファイル名
    Dim xlAppi As Excel.Application     ' (入力用)Excelアプリ
    Dim xlBooki As Excel.Workbook       ' (入力用)ワークブック
    Dim xlSheeti As Excel.Worksheet     ' (入力用)処理対象シート
    Dim xlAppo As Excel.Application     ' (出力用)Excelアプリ
    Dim xlBooko As Excel.Workbook       ' (出力用)ワークブック
    Dim xlSheeto As Excel.Worksheet     ' (出力用)処理対象シート
    Dim lngPutLine As LongPtr              ' 出力行
    Dim strLine_J As String             ' 工程用ワーク
    Dim strAtoJ As String               ' 明細行用ワーク
    Dim i As Long                       ' ループ用
    Dim j As Long                       ' ループ用
    Dim pos As Integer                  ' パスとファイル名の切り分け位置
    Dim Fn As Integer                   ' ファイル番号
    Dim tmp As Variant                  ' 区切り抽出用
    Dim flag As Boolean                 ' シートの有無
    Dim ws As Excel.Workbooks            ' シートの有無検索用

    ' 変数定義
    Err.Clear   ' エラーを初期化
    ErrMSG = "" ' エラーメッセージも一応初期化

    ' テンポラリファイル名を設定
    TempName = TempFolder() & Replace(DEF_FILENAME, "%1%", Format(Now(), "yyyymmddhhMMss")) & ".xlsx"

    '新規にブックを追加
    Workbooks.Add
    Dim strBookName As String
    Dim objWorkBook As Workbook
    Set objWorkBook = Workbooks.Application.ActiveWorkbook

    strBookName = objWorkBook.Name

    'アクティブにする
    objWorkBook.Worksheets(OUT_SHEET_NAME).Select

    ' ヘッダ出力
    With objWorkBook.Worksheets(OUT_SHEET_NAME)
        .Range("A1").Value = ""
        .Range("B1").Value = ""
        .Range("C1").Value = ""
        .Range("D1").Value = ""
        .Range("E1").Value = ""
        .Range("F1").Value = ""
        .Range("G1").Value = ""
        .Range("H1").Value = ""
        .Range("I1").Value = ""
        .Range("J1").Value = ""
        .Range("K1").Value = "o"
        .Range("L1").Value = ""
        .Range("M1").Value = ""
        .Range("N1").Value = ""
        .Range("O1").Value = ""
        .Range("P1").Value = ""
        .Range("Q1").Value = ""
        .Range("R1").Value = ""
        .Range("S1").Value = ""
        .Range("T1").Value = ""
        .Range("U1").Value = ""
        .Range("V1").Value = ""
        .Range("W1").Value = ""
        .Range("X1").Value = ""
        .Range("Y1").Value = ""
        .Range("Z1").Value = ""    
    End With

    ' 出力行の初期化
    lngPutLine = 2

    ' セットされているカウンタ分ループ
    For i = 0 To InFileCount - 1

        j = 0                                                                                                       ' 明細ループ初期化

        ' Excel(出力)ファイルオープン
        Set xlAppi = CreateObject("Excel.Application")                                                              ' Application生成
        xlAppi.Workbooks.Open Filename:=InFileName(i), UpdateLinks:=0                                               ' EXCELを開く
        xlAppi.Visible = False                                                                                      ' EXCELは表示しない

        ' シートのチェック
        If Not Sheet_Check(InFileName(i), TARGET_SHEET) Then
            ' 対象シートが無い場合
            MakeExcel = ""
            ' 対象外
            GoTo DiffentFile
        End If

        ' Excel(入力)ファイルオープン
        Set xlBooki = xlAppi.Workbooks(Dir(InFileName(i)))                                                          ' Workbook

        ' 処理対象
        Set xlSheeti = xlBooki.Worksheets(TARGET_SHEET)                                                             ' Worksheet

        ' 処理対象(セルA14=1)か？
        If xlSheeti.Cells(14, 1).MergeArea.Cells(1, 1).Value = "1" Then
            strLine_J = ""  ' 不良発見工程用ワーク初期化

            pos = InStrRev(InFileName(i), "\")                                                                      ' ファイルとパスに分ける準備
            With objWorkBook.Worksheets(OUT_SHEET_NAME)
                .Range("A" & lngPutLine & ":A" & lngPutLine).Value = Left(InFileName(i), pos)                       ' Excel解析(A:フォルダ名)
                .Range("B" & lngPutLine & ":B" & lngPutLine).Value = Mid(InFileName(i), pos + 1)                    ' Excel解析(B:ファイル名)
                .Range("C" & lngPutLine & ":C" & lngPutLine).Value = xlSheeti.Cells.Range(IN_BADNO).Value           ' Excel解析(C:不良番号)
                .Range("D" & lngPutLine & ":D" & lngPutLine).Value = xlSheeti.Cells.Range(IN_ISSUE_DATE).Value      ' Excel解析(D:発行年月日)
                .Range("E" & lngPutLine & ":E" & lngPutLine).Value = xlSheeti.Cells.Range(IN_ORDER).Value           ' Excel解析(E:オーダ)
                .Range("F" & lngPutLine & ":F" & lngPutLine).Value = xlSheeti.Cells.Range(IN_ORDER_SOURCE).Value    ' Excel解析(F:注文元)
                .Range("G" & lngPutLine & ":G" & lngPutLine).Value = xlSheeti.Cells.Range(IN_SUBJECT).Value         ' Excel解析(G:件名)
                .Range("H" & lngPutLine & ":H" & lngPutLine).Value = xlSheeti.Cells.Range(IN_MODELS).Value          ' Excel解析(H:機種)
                .Range("I" & lngPutLine & ":I" & lngPutLine).Value = xlSheeti.Cells.Range(IN_DECENES).Value         ' Excel解析(I:出検者)

                ' 複数選択を考慮
                ' *** 一番上 ***
                If xlSheeti.Cells.Range(IN_PROD_OUT).Value <> "" Then
                    strLine_J = strLine_J & "製外先立会/"
                End If
                If xlSheeti.Cells.Range(IN_PRO_IN).Value <> "" Then
                    strLine_J = strLine_J & "製外品受入/"
                End If
                If xlSheeti.Cells.Range(IN_UNIT).Value <> "" Then
                    strLine_J = strLine_J & "ユニット検査/"
                End If
                ' *** 真ん中 ***
                If xlSheeti.Cells.Range(IN_BORD_INSP).Value <> "" Then
                    strLine_J = strLine_J & "盤検査/"
                End If
                If xlSheeti.Cells.Range(IN_MARKING_CONF).Value <> "" Then
                    strLine_J = strLine_J & "現品会議/"
                End If
                If xlSheeti.Cells.Range(IN_HD_TEST).Value <> "" Then
                    strLine_J = strLine_J & "Ｈ／Ｗ試験/"
                End If
                ' *** 一番下 ***
                If xlSheeti.Cells.Range(IN_SYSTEM_TEST).Value <> "" Then
                    strLine_J = strLine_J & "システム試験/"
                End If
                If xlSheeti.Cells.Range(IN_SHIPPING_INSP).Value <> "" Then
                    strLine_J = strLine_J & "出荷検査/"
                End If
                If xlSheeti.Cells.Range(IN_FIELD_TEST).Value <> "" Then
                    strLine_J = strLine_J & "現地試験"
                End If
                ' 編集結果の最後にスラッシュがあれば削除
                If Right(strLine_J, 1) = "/" Then
                    strLine_J = Left(strLine_J, LenB(strLine_J) - 1)
                End If
                .Range("J" & lngPutLine & ":J" & lngPutLine).Value = strLine_J                                                              ' Excel解析(J:不良発見工程)

                ' 明細は同じ行のA列〜J列をコピーして貼り付けする為退避
                Range("A" & lngPutLine & ":J" & lngPutLine).Copy

                ' ここから明細行
                ' No(L)が入っている間明細ループ■■■■■■■■■■■■
                Do While Trim(xlSheeti.Cells.Range(IN_NO & CStr((14 + j * 6))).Value) <> ""
'                    If j > 1 Then
                        ' 2行目以降はA〜Jがないので追加
                        Range(lngPutLine & ":" & lngPutLine).PasteSpecial
'                    End If
                    .Range("K" & lngPutLine & ":K" & lngPutLine).Value = xlSheeti.Cells.Range(IN_NO & CStr((14 + j * 6))).Value            ' Excel解析(K:NO(A14→A20と6刻み)
                    .Range("L" & lngPutLine & ":L" & lngPutLine).Value = xlSheeti.Cells.Range(IN_SPOILAGE & CStr(15 + j * 6)).Value        ' Excel解析(L:仕損)
                    .Range("M" & lngPutLine & ":M" & lngPutLine).Value = xlSheeti.Cells.Range(IN_BURDEN & CStr(15 + j * 6)).Value          ' Excel解析(M:負担)
                    .Range("N" & lngPutLine & ":N" & lngPutLine).Value = xlSheeti.Cells.Range(IN_PHENOMENON & CStr(18 + j * 6)).Value      ' Excel解析(N:現象)*
                    .Range("O" & lngPutLine & ":O" & lngPutLine).Value = xlSheeti.Cells.Range(IN_NUM_DEFECTS & CStr(18 + j * 6)).Value     ' Excel解析(O:不良数)*
                    .Range("P" & lngPutLine & ":P" & lngPutLine).Value = xlSheeti.Cells.Range(IN_PRODUCT & CStr(15 + j * 6)).Value         ' Excel解析(P:品名)
                    ' ここからは全部で１行なので別計算
                    .Range("Q" & lngPutLine & ":Q" & lngPutLine).Value = xlSheeti.Cells.Range(IN_TROUBLE_CONTENT & CStr(14 + j * 6)).Value   ' Excel解析(Q:不具合内容／処置依頼事項)※
                    .Range("R" & lngPutLine & ":R" & lngPutLine).Value = xlSheeti.Cells.Range(IN_DEADLINE & CStr(14 + j * 6)).Value        ' Excel解析(R:処置期限)
                    .Range("S" & lngPutLine & ":S" & lngPutLine).Value = xlSheeti.Cells.Range(IN_COR_NECECE & CStr(14 + j * 6)).Value      ' Excel解析(S:是正要否)
                    .Range("T" & lngPutLine & ":T" & lngPutLine).Value = xlSheeti.Cells.Range(IN_TREATMENT & CStr(14 + j * 6)).Value       ' Excel解析(T:処置・対策内容)※
                    .Range("U" & lngPutLine & ":U" & lngPutLine).Value = xlSheeti.Cells.Range(IN_TREATMENT_DAY & CStr(14 + j * 6)).Value   ' Excel解析(U:処置日)
                    .Range("V" & lngPutLine & ":V" & lngPutLine).Value = xlSheeti.Cells.Range(IN_RELAP_PREVENT & CStr(14 + j * 6)).Value   ' Excel解析(V:再発防止)※
                    .Range("W" & lngPutLine & ":W" & lngPutLine).Value = xlSheeti.Cells.Range(IN_TC_RESULT & CStr(14 + j * 6)).Value       ' Excel解析(W:処置確認結果)※
                    .Range("X" & lngPutLine & ":X" & lngPutLine).Value = xlSheeti.Cells.Range(IN_DATE_CONFIR & CStr(14 + j * 6)).Value     ' Excel解析(X:確認日)
                    .Range("Y" & lngPutLine & ":Y" & lngPutLine).Value = xlSheeti.Cells.Range(IN_CONFIR_PERSON & CStr(14 + j * 6)).Value   ' Excel解析(Y:確認者)
                    .Range("Z" & lngPutLine & ":Z" & lngPutLine).Value = xlSheeti.Cells.Range(IN_TREATMENT_SECTION).Value                  ' Excel解析
                   j = j + 1
                   lngPutLine = lngPutLine + 1
                Loop
            End With
        Else
            ' 対象外
            GoTo DiffentFile
        End If

        ' カーソルをA1に移動
        Cells(1, 1).Select
        skipFlg = True

DiffentFile:

        ' Excelファイルクローズ
        xlAppi.Quit                                      ' EXCELを閉じる(入力)

        Set xlSheeti = Nothing                           ' オブジェクトの解放(入力)
        Set xlBooki = Nothing                            ' オブジェクトの解放(入力)
        Set xlAppi = Nothing                             ' オブジェクトの解放(入力)

    Next

    If skipFlg Then
        ' セルの調整
        Columns("A:Y").EntireColumn.AutoFit                 ' 全体の自動調整
        Columns(1).ColumnWidth = 25                         ' フォルダ名の幅調整
        Columns(2).ColumnWidth = 25                         ' ファイル名の幅調整

        '名前を付けて保存
        objWorkBook.SaveAs TempName
    End If

    '閉じる
    Application.DisplayAlerts = False
    objWorkBook.Close

    ' クローズ
    Set xlSheeto = Nothing                              ' オブジェクトの解放(出力)
    Set xlBooko = Nothing                               ' オブジェクトの解放(出力)
    Set xlAppo = Nothing                                ' オブジェクトの解放(出力)

    MakeExcel = TempName
    Exit Function
Err_MakeExcel:
    ErrMSG = CStr(Err.Number) & ":" & Error
    Set xlSheeti = Nothing                           ' オブジェクトの解放(入力)
    Set xlBooki = Nothing                            ' オブジェクトの解放(入力)
    Set xlAppi = Nothing                             ' オブジェクトの解放(入力)
    Set xlSheeto = Nothing                           ' オブジェクトの解放(出力)
    Set xlBooko = Nothing                            ' オブジェクトの解放(出力)
    Set xlAppo = Nothing                             ' オブジェクトの解放(出力)
    MakeExcel = ""
End Function

' **************************************************
' 機能 ：WindowsのTempフォルダの取得
' 戻値 ：WindowsのTempフォルダ
' **************************************************
Private Function TempFolder() As String

    Dim FolderName As String

    FolderName = Space(MAX_PATH)
    Call GetTempPath(LenB(FolderName), FolderName)
    TempFolder = Left(FolderName, InStr(1, FolderName, vbNullChar) - 1)

End Function

' **************************************************
' 機能 ：Excelのシートの有無をチェック
' 引数 ：なし
' 戻値 ：True=あり
' **************************************************
Function Sheet_Check(Book As String, Sheet As String) As Boolean

    Dim rt As Boolean
    Dim fs As Object

    ' ファイルシステムオブジェクト
    Set fs = CreateObject("Scripting.FileSystemObject")

    rt = False  ' 存在しない
    If (fs.FileExists(Book)) Then
        Workbooks.Open Filename:=Book   ' 引数のブックをオープン
        'Windows(Book).Activate
        rt = True
        On Error GoTo SheetErr
        Sheets(Sheet).Select
        On Error GoTo 0
        ActiveWindow.Close
    End If
    Set fs = Nothing

    Sheet_Check = rt
    Exit Function
SheetErr:
    rt = False
    Resume Next
End Function

（マツ） 2020/11/27(金) 17:34

---

既にタイトルとは別のエラーに関する質問ということでよろしいですか？

Public Const E04 As String = "対象のファイルが存在しません。"←このエラーメッセージが表示します。 今度は E04 が宣言以外に存在しません。
エラーを起こしている場所がなければ答えようがないでしょう。
ここまで長いと全文読んで解読しようという気にもなりません。

きりがないので、私は下ります。
（通りすがりの） 2020/11/27(金) 20:05

---

回答ありがとうございます。
内部エラーについて調べます。
（マツ） 2020/11/28(土) 00:01

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.