Results of 1 - 1 of about 37670 for IF (0.007 sec.)
- [[20201126171413]]
- #score: 1591
- @digest: 3e3cd05826a7310536a32c7e43e8d321
- @id: 85900
- @mdate: 2020-11-27T15:01:56Z
- @size: 42084
- @type: text/plain
- #keywords: lngputline (411566), arydir (377054), aryret (356645), xlsheeti (280471), strname (208566), intcount (172626), aryfile (158169), infilecount (118626), 析( (114728), 応-- (104108), strline (98553), infilename (79759), 放( (73953), getfiles (54876), longptr (51949), 列ar (47435), 合対 (46272), errmsg (35953), swap (33587), プカ (32811), タdi (27926), 解析 (25474), 象フ (23210), 力) (20935), 解放 (13872), const (10830), 名) (9925), string (9175), cstr (8889), ビッ (8304), 不具 (7541), ファ (7412)
- 『Excel64ビット変更後の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 & "H/W試験/" 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:品名) ' ここからは全部で1行なので別計算 .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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202011/20201126171413.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97018 documents and 608145 words.
訪問者：