• ベストアンサー

ExcelVBA どこが間違えていますか?

ExcelVBA 初心者です。 下記のようなプロシージャを人様の作ったのをコピーして作ったのですが意図したとおりになりません。どこが間違っているのか教えてください。 私の意図は選択したフォルダの中の全ファイル(Book)名をアクティブシートのA列に順番に表示したい、です。今は実行すると全部セルA1に表示されてしまって、最後の1つのファイル名しか分かりません。ファイルごとに別のセルに表示したいのです。よろしくお願いします。 Sub ファイル一覧() Dim foldername As String Dim filename As String Dim i As Integer Dim dlg_folder As FileDialog Set dlg_folder = Application.FileDialog(msoFileDialogFolderPicker) Folder_Dialog: dlg_folder.Show If dlg_folder.SelectedItems.Count <> 1 Then Exit Sub Else foldername = dlg_folder.SelectedItems.Item(1) MsgBox "選択したフォルダは " & foldername & " です。" filename = Dir(foldername & "\*.xls", vbNormal) If filename = "" Then MsgBox "Excelファイルがありません。" GoTo Folder_Dialog End If End If Set dlg_folder = Nothing Do While filename <> "" For i = 1 To Workbooks.Count Cells(i, 1).Value = filename i = i + 1 Next i filename = Dir() Loop MsgBox "フォルダ " & foldername & " の中のファイルはすべて表示されました。" End Sub あれ、なぜかインデントが無効になっています。

質問者が選んだベストアンサー

  • ベストアンサー
  • ki-aaa
  • ベストアンサー率49% (105/213)
回答No.1

全体的な処理の流れは理解できませんが、次の部分をこうしたらどうでしょうか。 Do While filename <> "" For i = 1 To Workbooks.Count Cells(i, 1).Value = filename i = i + 1 Next i filename = Dir() Loop を次のようにする i = 1 Do While filename <> "" Cells(i, 1).Value = filename i = i + 1 filename = Dir() Loop

shonenA
質問者

お礼

ご回答感謝いたします。 ご教示の方法で意図したとおりの結果を得られました。 不思議なことにさっきまであなた様のご回答が表示されませんでした。No.2のかたのご回答がNo.1になっていました。時間を見るとあなた様の方が早かったのですね。当方ダイアルアップ接続のためでしょうか?? No.2のかたへのお礼が先になってしまいました。申し訳ありません。また、教えてください。

その他の回答 (1)

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.2

下記で動きました、ただフォルダの指定は直接にしました。拡張子(filenameのright3桁)をXLSに絞ればエクセルブックだけに出来ます。 Sub ファイル一覧() Dim foldername As String Dim filename As String Dim i As Integer foldername = "c:\My Documents\" MsgBox "選択したフォルダは " & foldername & " です。" filename = Dir(foldername) i = 1 Do While filename <> "" Cells(i, 1).Value = filename i = i + 1 filename = Dir() Loop MsgBox "フォルダ " & foldername & " の中のファイルはすべて表示されました。" End Sub ・Dim dlg_folder As FileDialog でエラーになりました。(エクセル2000) ・前半は理解不能。後半のForで回し、DoWhileで回し、何故2重ループしないといけないのか判らない。 ただ私も初心者ですが。WorkBookはファイルで、 ブックの数だけ回したとして、なぜまたDoWhileで 回すのでしょうか。

shonenA
質問者

お礼

いつもお教えいただき感謝しています。 あなた様が初心者なら、私は超^3の初心者です。人様の作品なので私も良く分かりません。前半は任意のフォルダを選択する意味のようです。これも私の意図するところの1つです。 Do While filename <> "" For i = 1 To Workbooks.Count Cells(i, 1).Value = filename i = i + 1 Next i filename = Dir() Loop i = 1 の部分をご教示いただいた Do While filename <> "" Cells(i, 1).Value = filename i = i + 1 filename = Dir() Loop に書き換えると私の意図したとおりになるようです。ありがとうございました。

関連するQ&A

  • 【Excel VBA】ファイルにヘッダーを挿入

    Excel VBAが初心者です、よろしくお願いします。 仕事で必要なため本を読みながら挑戦しております。 アドバイスをいただけると助かります。 【実現したいこと】 あるフォルダ内に格納された多くのファイルに、ヘッダーを挿入します。ヘッダー挿入後のファイルは、新ファイルで保存をします。 詳細は下記のとおりです。また、作りかけのプログラムも以下のとおりです。 【詳細】 ・あるフォルダ:0001tokyou、0002tokyou・・・1000tokyou・・・(数字4桁は固定+tokyou)というファイルが格納されております。ファイル数はそのときによって異なります。これらは拡張子が無いファイルですが、メモ帳で開くことができます。VBAではフォルダを選択できることとします。 ・ヘッダー:ヘッダーは1種類ですが、項目は10個あります。 ・新ファイル保存:ヘッダー挿入前のファイル「0001tokyou」にヘッダーを挿入したら、「0001kantou」という新しいファイルで保存します。従って、0001tokyouファイルは存在したままです。 【作りかけのプログラム】 Sub ヘッダ挿入と別名保存() Dim myFile As String Dim mydata As String Dim myArray() As String Dim fileName As String Dim folderName As String Dim i, j As Integer Dim header As Variant header = Array("氏名", "性別", "年齢", "生年月日", "住所", "マンション名", "備考1", "備考2", "備考3", "備考4") '挿入するヘッダーを定義する。 If Application.FileDialog(msoFileDialogFolderPicker).Show Then folderName = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) End If '加工するファイルが格納されているフォルダを指定する。 If folderName = "" Then MsgBox "フォルダが指定されませんでした。処理を終了します。", vbOKOnly Exit Sub End If '加工するファイルが格納されているフォルダが指定されなかった場合の処理です。 fileName = Dir(folderName & "\*") Do While fileName <> "" myFile = Workbooks.Open fileName:=folderName & "\" & fileName For i = 0 To 8 'ヘッダーを新ファイルに挿入する。 Cells(1, i + 1).Value = header(i + 1) Next i fileName = Dir() Loop End Sub アドバイスをいただけると助かります。 よろしくお願いします。

  • 変数を保持して呼び出す方法

    変数を保持する方法 2022/02/10 15:36 変数が受け継がれない 2022/02/10 15:24 sub A(),subB()と複数のプロシージャをModule1に配置。 Sub Aでターゲットファイル(T_File)を指定して Sub Bで同じT_Fileを呼び出そうとしたのですが Subの前に配列は宣言しているのでPrivateのハズなのに 変数が受け継がれません T_Fileが”””となります。 多分、Sub A()が終了した時点で一度マクロが終了して 新たにSub B()を呼び出すので上手く変数が受け継がれないのだと思います。 何処かのシートのセルに変数を保持して呼び出す方法が考えられますが そのほかに変数を保持する方法は有りませんか? (できればシートのセルに保持しない方法があれば教えて下さい。) 以下コード(コードが長いので必要と思われる所だけを記載しています。) ’------------------------------------ Option Explicit Dim dlg As FileDialog Dim T_File As String Sub A() Set dlg = Application.FileDialog(msoFileDialogFilePicker) If dlg.Show = False Then MsgBox "処理はキャンセルされました。" Exit Sub Else End If '指定テキストファイル読み込み T_File = dlg.SelectedItems(1) '(途中のコード省略) If rc = vbNo Then MsgBox "処理を中止します。", vbCritical Exit Sub Else MsgBox "処理が終了しました。", vbInformation End If End Sub Sub B() ’T_File = dlg.SelectedItems(1) Folder_Name = CreateObject("Scripting.FileSystemObject").GetParentFolderName(T_File) End Sub

  • 指定ファイルのみ読み込んで表示する

    現在、以下のコードで指定フォルダー内の全ファイルをA2以下に読み込んでいます。 これでは、処理する必要のないファイルまで読み込まれてしまいます。 (そのため、現在は処理必要ないファイルは手動でA列から削除しています。) Set dlg = Application.FileDialog(msoFileDialogFolderPicker) を Set dlg = Application.FileDialog(msoFileDialogFilePicker) に変更すると ユーザーがファイルを処理が必要なファイルのみ選択できそうですが その場合、どのように変更すれば良いですか ? ’-------------------------------------------------------------- Option Explicit Public dlg As FileDialog Public fol_path As String 'フォルダのフルパス Sub フォルダを指定してファイル名一覧を作成する() Dim f_name As String 'ファイル名 Dim i As Long 'ファイル名を出力する行番号 '書き出しセル初期化 Range("A2:B100").ClearContents 'フォルダを指定するモードでFileDialogを表示 Set dlg = Application.FileDialog(msoFileDialogFolderPicker) '読み込み初期フォルダーの指定 dlg.InitialFileName = "C:\Users\Nubo\Desktop\Temp\" If dlg.Show = False Then MsgBox "処理はキャンセルされました。" Exit Sub Else End If fol_path = dlg.SelectedItems(1) '指定されたフォルダのフルパスを変数に格納 f_name = Dir(fol_path & "\*") 'Dir関数を使って、指定されたフォルダ内の一つ目のファイル名を取得 If f_name = "" Then MsgBox fol_path & " にはファイルが存在しません。" Exit Sub End If 'シートに書き出す Range("C1").Value = fol_path & "のファイル一覧" Range("A1").Value = "現在のファイル名" '見出し行の表示(太字、フォントサイズ 12) With Range("A1:B1") .Font.Bold = True .Font.Size = 12 End With 'A2セルから下にファイル名を書き出し i = 2 Do Until f_name = "" Cells(i, "A").Value = f_name i = i + 1 '次のファイル名を取得 f_name = Dir Loop 'セルの内容に合わせて列幅を自動調整する Range("A:D").EntireColumn.AutoFit MsgBox Sheets("DATA").Name & "にファイル名一覧を作成しました。" & Chr(13) & _ "変名に必要ないファイル名があれば削除してください。" End Sub ’----------------------------------- Office 2021,Windows_11

  • フォルダー名に特殊文字?が存在する場合にエラー発生

    以下のコードでフォルダー名を取得しています。 しかし、フォルダー名に特殊文字?が存在する場合に下記でエラーが発生します。  例えば「Oxygène」 でeの上に’があるなど   If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then      実行エラー 53: ファイルが見つかりません。 これは、excelの仕様で処理できないのでしょうか ? 他のコードで処理できれば教えて下さい。 --------------------------------------- Sub フォルダ名取得() Dim MyName Dim MyPath Dim i As Long ’仮の消込(初期化: 前回の記入文をクリアー) Range("A5:H50").Clear i = 1 ' フォルダーを自由に選べること。 参考:officeTANAKA With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then ' MsgBox .SelectedItems(1) If Len(.SelectedItems(1)) = 3 Then ' c:\の場合とサブフォルダーの場合 MyPath = .SelectedItems(1) Else MyPath = .SelectedItems(1) & "\" End If End If End With If MyPath = Empty Then MsgBox "フォルダー名表示をキャンセルしました。": Exit Sub 'Range("b2:c2").ShrinkToFit = True ' 縮小してセル内に表示 MyName = Dir(MyPath, vbDirectory) ' 最初のフォルダ名を返します。 '親フォルダー Range("A2") = MyPath Do While MyName <> "" ' ループを開始します。 ' 現在のフォルダと親フォルダは無視します。 If MyName <> "." And MyName <> ".." Then ' ビット単位の比較を行い、MyName がフォルダかどうかを調べます。 If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then Range("a" & i + 4) = MyPath & MyName ' アクティブシートA5セルから下方にフルパス表示。 Range("b" & i + 4) = MyName ' アクティブシートB5セルから下方にフォルダ名表示 i = i + 1 End If End If MyName = Dir ' 次のフォルダ名を返します。 Loop MsgBox MyPath & "の中にフォルダーは" & (i - 1) & "個のフォルダーがありました。" End Sub

  • EXCEL→CSV形式で別ファイルに保存

    EXCELデータ内のある1つのシートのデータをそのまま別ファイル(CSV)に保存したいのですがうまくいかないので教えてください。 本を見ながらこのようなマクロを作ったところ、EXCEL(○○.xls)の指定したシート(keihi)のみをCSV形式で別フォルダ(C:\経費振替)に保存することができたんですが、 元のEXCELも、ファイル名称・形式がCSV(○○.xls→keihi.csv)に変わってしまいます。 エクセルのファイル名、形式は変えずにできる方法ってありますか?? Sub データはきだし() Dim Ret As String Dim Res As Integer Dim FolderName As String Set WK1 = Worksheets("1 依頼書") Set WK4 = Worksheets("keihi") FolderName = "C:\経費振替" Ret = Dir(FolderName, 16) If Ret = "" Then Res = MsgBox("DATA保管用フォルダを作成します。", vbYesNo) If Res = vbYes Then MkDir FolderName End If End If ' Dim Res2 As Integer Res2 = MsgBox("DATAを作成します。", vbYesNo) WK4.Select If Res2 = vbYes Then With WK4 .SaveAs Filename:=FolderName & "\keihi", FileFormat:=xlCSV ←多分ココが何か間違ってるのだと思うんですが。 End With

  • ACCESS エクスポート ダイアログ ファイル名取得

    ACCESS2003で作成したデータをダイアログで指定したファイル名でエクスポートしたいのですが、上手くできません。 ダイアログが開きその指定したフォルダーにあるエクセルファイルを選択すれば、正常にエキスポートできるのですが、 開いたダイアログにファイル名を入力すると、それ以降動かなくなります。 基本的なことが間違っているのでしょうか?? 詳しい方教えてください。下記にコードした内容を書きました。 よろしくお願いします。 Private Sub cmbTransExcel_Click() On Error GoTo Err_cmbTransExcel_Click Dim fileSaveName As Variant Set dlg = Application.FileDialog(msoFileDialogOpen) With dlg .Title = "チェック" .ButtonName = "エキスポート" .InitialFileName = "C:\Program Files\DATA\" .InitialView = msoFileDialogViewList .AllowMultiSelect = False .Filters.Clear .Filters.Add "xls", "*.xls" End With With dlg If .Show = -1 Then For Each vntPath In dlg.SelectedItems strPath = vntPath Next Else Set dlg = Nothing Exit Sub End If End With Set dlg = Nothing Dim strac As String Dim varxls As Variant Dim strmsg As String strac = "Q_チェック" 'Accessファイルを指定します。 varxls = strPath 'エクセルファイルを指定します。 strmsg = strac & " を、Excelファイルへ出力します。" & Chr(13) & _ "出力先は" & varxls & "、 シート名は" & strac & "です。" & _ Chr(13) & "よろしければ、OKをクリックして下さい。" If MsgBox(strmsg, vbOKCancel) = vbOK Then '最初のデータをフィールド名として使います。 DoCmd.TransferSpreadsheet acExport, _ acSpreadsheetTypeExcel9, strac, varxls, True MsgBox "EXCELの出力が正常終了しました。", vbInformation, "処理終了" End If Exit_cmbTransExcel_click: Exit Sub Err_cmbTransExcel_Click: MsgBox "EXCELの出力が異常終了しました。", vbCritical, "エラー!" Resume Exit_cmbTransExcel_click End Sub

  • 複数フォルダー名(ファイル名)を書き出す

    現在、以下のコードで   フォルダー名又はファイル名(拡張子ナシ)をA2セルに書き込むようにしています。   これを複数個読み込むように改造できないでしょうか ?   読み込む回数を指定してA2から下へ順番に回数分だけループさせて書き込んでいけば   処理自体は完結します。   それでは、ループ回数が増えればそれだけ手数が必要なので   現在は、ファイラーでターゲットを複数選択状態で   右クリック拡張で機能追加した「ファイル名(フォルダー名)をコピー」を選択して   A2に一括してコピペしています。    (ctrl+左クリックで複数選択可能)   ファイラーを利用する方法でも良いのですが、   EXCELだけで複数個読み込むように改造することはできますか ? ----------------------------------------- 大幅な改造と言うか、ほぼ新しく作成になるようなら   WEBの参考記事だけの紹介でも十分です。 ------------------------------------------     Sub FolderName__FileName__Picker() Dim dlg As Object Dim blAns As Boolean Dim p As Single Dim FolName As Variant Dim rc As VbMsgBoxResult Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Sheets("DATA") Set Ws2 = Sheets("Number") 'DATA,Numberシートの初期化(全体=数式・文字・書式・コメント全てをクリア) Ws1.Range("A1:XX100").Clear Ws2.Range("A1:XX100").Clear 'フォルダー名又はファイル名、いずれで処理するか ? rc = MsgBox("Folder名で処理しますか ?", vbYesNo + vbQuestion, "Folder処理 or File処理") If rc = vbYes Then 'Get FolderName(フォルダー名で処理) Set dlg = Application.FileDialog(msoFileDialogFolderPicker) blAns = dlg.Show If blAns Then FolName = dlg.SelectedItems(1) p = InStrRev(FolName, "\") Range("A1") = "フォルダー名(拡張子を含まない)" Ws1.Range("A1").HorizontalAlignment = xlCenter Ws1.Range("A1").Font.Bold = True Ws1.Range("A2") = Mid(FolName, p + 1, Len(FolName) - p) Else MsgBox "フォルダ選択がキャンセルされました。" End If Else 'GetFileName without Filename Extension(ファイル名で処理、拡張子は除く) Dim GetFileName As String Dim FNLen As Single GetFileName = Application.GetOpenFilename() GetFileName = Dir(GetFileName) FNLen = Len(GetFileName) GetFileName = Left(GetFileName, FNLen - 4) Ws1.Range("A1") = "ファイル名" Ws1.Range("A1").HorizontalAlignment = xlCenter Ws1.Range("A1").Font.Bold = True Ws1.Range("A2") = GetFileName 'パスを含まないファイル名 End If '続けてNumberling処理するか選択 rc = MsgBox("Numberling ?", vbYesNo + vbQuestion, "連続処理") If rc = vbYes Then Call Nubering3 Else MsgBox "Numberling処理がキャンセルされました。" End If End Sub

  • サブフォルダ内のファイル名取得について

    Windows7 Access 2013環境です。 USB接続したハードディスク内のファイルリストを作成しようとしています。 ハードディスクはNTFSフォーマットです。 ボタン1をクリックしたとき、テーブル1をソースにしたフォーム1に ファイル名を書き出していくようにしました。 ドライブ内のサブフォルダを選択すると、プログラムは正常に作動するのですが ドライブ直下を指定すると、実行時エラー 70 "書き込みできません" が発生します。 NTFSのアクセス権は、管理者でログインしているので、システム関連のフォルダ System Volume Information $RECYCLE.BIN 以外は問題ありません。 どこに問題があるのでしょうか。もし、システム関連のフォルダが 引っかかっているとしたら、その回避方法についても 具体的にご教授願います。 ↓エラー箇所↓ -------------------------------------------------------------- For Each subfolder In folder.SubFolders -------------------------------------------------------------- ↓作成したプログラム↓ -------------------------------------------------------------- Private Sub ボタン_1_Click() Dim dlg As FileDialog Dim fold_path As String Dim strTargetDir As String DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec Set dlg = Application.FileDialog(msoFileDialogFolderPicker) If dlg.Show = False Then Exit Sub fold_path = dlg.SelectedItems(1) strTargetDir = fold_path Call FolderSearch(strTargetDir) MsgBox "終了" Set dlg = Nothing Else End If End Sub Public Sub FolderSearch(strTargetDir As String) Dim fso As Object Dim folder As Object Dim subfolder As Object Dim file As Object Dim objFilsSys As Object Dim objDrive As Object Dim strDriveLetter As String Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(strTargetDir) strDriveLetter = Left(strTargetDir, 1) Set objFileSys = CreateObject("Scripting.FileSystemObject") Set objDrive = objFileSys.GetDrive(strDriveLetter) For Each subfolder In folder.SubFolders  ←エラー箇所 FolderSearch subfolder.Path Next subfolder For Each file In folder.Files With file Me.ボリューム名 = objDrive.VolumeName Me.ファイル名 = file.Name Me.ファイルパス = folder.Path Me.ファイルサイズ = folder.Size DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec End With Next file Set objDrive = Nothing Set fso = Nothing Set folder = Nothing End Sub

  • [と”の意味を教えてください。

    http://okwave.jp/qa/q5945112.html を参考に、 Sub test1() Dim i As Integer i = 2 If i Like "[1-3]" Then MsgBox i & "です" End If End Sub Sub test2() Dim i As Integer i = 2 If i Like "[1-5]" Then MsgBox i & "です" End If End Sub Sub test3() Dim i As Integer i = 2 If i Like "[1-10]" Then MsgBox i & "です" End If End Sub を作ったのですが、 test3はうまく行きません。 意味としては、 iが "[1-10]"の中の数字の間のどれかであれば、 MsgBox i & "です" を表示させたいです。 でも上記のマクロを実行させた結果、 "[1-10]"の中で計算が行われてるのではないかと思います。 だから、test3は、1-10=-9 という事になり、msgboxが反応しないのではないかと思っています。 でもそうすると、test2だって "[1-5]"は、-4になって、i=2とは違う値なのに なぜMsgBoxが反応してしまうのかわかりません。 でもそもそも[と”の意味が分からないのでそこから教えていただけませんか? “の意味、は二つで挟んで文字列にすると思っています。

  • エクセルVBA:取得したファイル情報を別シートに貼るには・・・

    いつもお世話になっています。 今エクセルVBAで指定したフォルダ内のファイル情報を取得し、sheet2に貼り付けるものを作っています。 指定したフォルダ内のファイル情報を取得するまでは分かったのですが、作ったVBAを実行するとsheet1のA2セルから自動的に貼り付けられてしまいます。 sheet2のA1セルから貼り付けるにはどうすれば良いのでしょうか?? 作ったVBAはこんな感じです。 まず、フォルダのパスを取得しA2セルへ表示します。 Sub test2()  With Application.FileDialog(msoFileDialogFolderPicker) If .Show = 0 Then Exit Sub Range("A2").Value = .SelectedItems(1) End With End Sub 次に、A2セルの値を使ってファイル名を取得しました。 Sub Test() Dim i As Long Dim pass As String pass = Range("A2").Value With Application.FileSearch .NewSearch .LookIn = pass .FileType = msoFileTypeAllFiles .SearchSubFolders = True If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Cells(i + 1, 1) = .FoundFiles(i) Cells(i + 1, 3) = FileDateTime(.FoundFiles(i)) Next i End If End With End Sub です。 長くて申し訳ありません。よろしくお願いします。

専門家に質問してみよう