• 締切済み

選択ファイル（フルパス名）をアクティブセルから表示

ダイアログボックスが自動的に開き選択ファイル（フルパス名） が表示されるVBEがあるんですが、（下記参照）改良したい点がありますので見て下さい。 Sub Excelファイル() Dim i As Integer Dim xFileNames As Variant, xFile As Variant, xDir As String With Application.FileDialog(msoFileDialogFilePicker) xFileNames = Application.GetOpenFilename( _ FileFilter:="Excel ファイル (*.xls; *.xlsx; *.xlsm),*.xls; *.xlsx; *.xlsm", MultiSelect:=True) If IsArray(xFileNames) Then i = 1 For Each xFile In xFileNames 'Xファイルネーム（フルパス名）すべての要素に同じ処理を繰り返す xDir = Dir(xFile) '変数xDir=xファイル名（ファイル名） If i = 1 Then 'i=1の場合（選択ファイル一つ目の場合） Cells(i, 1).Value = Replace(xFile, xDir, "") 'A列の中にフルパスからファイル名を取り除いた値を表示する Cells(i, 1).Offset(1).Value = xDir '1行下の値がファイル名である。 i = i + 2 'iに2を加えてループ Else '違う場合 Cells(i, 1).Value = xDir 'A列に順にファイル名を表示する i = i + 1 'ｉに1を加えてループ End If Next xFile 'xファイルに戻る End If Cells(Rows.Count, 1).End(xlUp).Offset(1).Activate 'データの最終行をA列で検知して一つ下の行がアクティブセル End With End Sub この命令文だとA1セルから縦に順にフルパス名が表示され、データの最終行の一つ下がアクティブセルになるようになっています。 改良したい点は、A列限定ではなくアクティブセルから順に上記と同じようにフルパス名が表示され、データの最終行の一つ下にアクティブセルがくるVBEに改良したいです。 ※上記VBEのようにアクティブセルに選択ファイル一つ目のフルパスからファイル名を取り除いたデータを表示し、 　　Offset(1,0)に選択ファイル一つ目のファイル名のみを表示、Offset2以降は選択ファイル2つ目以降のファイル名だけを表示するようにする。 VBA初心者なので、上記のようにそれほど難しくない構文で仕上げたいのですが、 もしできる方いましたら教えてください。 よろしくお願いいたします。

みんなの回答

  • queuerev2
  • ベストアンサー率78% (96/122)
回答No.1

質問投稿後かなり日数がたっていますが今でもお役にたてるでしょうか。 とりあえず最低限の修正をしてみました。 修正点は以下の通りです。 １．iの型はIntegerからLongに（32768行以下に対応） ２．i（行番号）の初期値を1からActiveCell.Rowに変更。 　（選択ファイル一つ目かどうかの判定も同様に変更） ３．Cellsの列番号を1からActivecell.Columnに変更 コードは以下の通りです。 Sub Excelファイル() Dim i As Long Dim xFileNames As Variant, xFile As Variant, xDir As String With Application.FileDialog(msoFileDialogFilePicker) xFileNames = Application.GetOpenFilename( _ FileFilter:="Excel ファイル (*.xls; *.xlsx; *.xlsm),*.xls; *.xlsx; *.xlsm", MultiSelect:=True) If IsArray(xFileNames) Then i = ActiveCell.Row For Each xFile In xFileNames 'Xファイルネーム（フルパス名）すべての要素に同じ処理を繰り返す xDir = Dir(xFile) '変数xDir=xファイル名（ファイル名） If i = ActiveCell.Row Then 'i=アクティブセルの行の場合（選択ファイル一つ目の場合） Cells(i, ActiveCell.Column).Value = Replace(xFile, xDir, "") 'A列の中にフルパスからファイル名を取り除いた値を表示する Cells(i, ActiveCell.Column).Offset(1).Value = xDir '1行下の値がファイル名である。 i = i + 2 'iに2を加えてループ Else '違う場合 Cells(i, ActiveCell.Column).Value = xDir 'A列に順にファイル名を表示する i = i + 1 'ｉに1を加えてループ End If Next xFile 'xファイルに戻る End If Cells(Rows.Count, ActiveCell.Column).End(xlUp).Offset(1).Activate 'データの最終行をA列で検知して一つ下の行がアクティブセル End With End Sub ところで、最後のアクティブセルを移動するところですが、このプロシージャを複数回使用してその結果を連続したセルに表示するなら、以下のようにした方がいいのではないでしょうか。 Cells(i, ActiveCell.Column).Activate

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. その他（プログラミング・開発）

関連するQ&A

  • 画像ファイル名をパス付きで表示

    Sub Test2() Dim objFSO As Object Dim sPath As String, sSubFol As String, sFileName As String Dim nRow As Long, nCol As Long Set objFSO = CreateObject("Scripting.FileSystemObject") sPath = "C:\Users\Owner\Downloads\base\setting_000002016\" nRow = 2 sSubFol = Cells(nRow, 1).Text Do While sSubFol <> "" nCol = 11 sFileName = Dir(sPath & sSubFol & "\*.jpg") If objFSO.FileExists(sPath & sSubFol & "\" & sSubFol & ".jpg") Then nCol = 12 Else nCol = 11 End If Do While sFileName <> "" If sFileName = sSubFol & ".jpg" Then Cells(nRow, 11) = sFileName Else Cells(nRow, nCol) = sFileName nCol = nCol + 1 End If sFileName = Dir() Loop nRow = nRow + 1 sSubFol = Cells(nRow, 1).Text Loop Set objFSO = Nothing End Sub こちらは商品番号とサブフォルダの名前が一致したらフォルダ内のファイル名を抽出するというマクロですが、これをパス付で表示という動作をするにはどこをいじればよろしいでしょうか？

  • VBAでExcelのセルの一覧からファイル名の変更が

    こんにちは。会社で大量のファイル名を変更していますが、Excelで一覧からを変更できれば能率的なので作っていますが、困っています。下記のものです。 Sub リネーム() Dim i As Long　 Dim NEWファイル As String　 Dim OLDファイル As String　 Dim パス As String For i = 1 To Range("B65536").End(xlUp).Row パス = Cells(2, 1).Value OLDファイル = パス & Cells(i, 2).Value NEWファイル = パス & Cells(i, 3).Value If Dir(OLDファイル) <> "" Then Name OLDファイル As NEWファイル End If Next i End Sub ※A2にはC:\Documents and Settings\M．Co，\デスクトップ\リネームと入っています。B1には変更前の001.jpg、C1には変更するa-1.jpgとファイル名が入っています。実行してもファイル名は変更されません。エラーもでません。よろしくお願いします。

  • ExelVBAでのアクティブセルの記述

    Excelマクロ初心者です。 今会社で出勤表のマクロを組んでいるのですが、 「アクティブセルが○列にあった場合、アクティブセルを２行下、３０列左に移動させ、それ以外だと右に一つ移動」 という構文は、 「If アクティブセルが○列にある Then ActiveCell.Offset(2, -30).Select Else ActiveCell.Offset(0, 1).Select End If」 となると思うのですが、その肝心な「アクティブセルが○列にある」の記述の仕方が分かりません。 どうかご教授ください。

  • 2つの列のANDで一致したファイルの移動

    とあるシートのB列の値かつAM列の値と、とあるフォルダ内にあるファイルの名称が部分一致したときに、 そのファイルを移動先のフォルダへと移動させるVBAを教えていただけないでしょうか? この内容のVBAを作ったのですが、エラーが出てしまいます（エラーの箇所はコード内に示している）、またこのエラーが影響しているか分からないのですが分別されているのですが上手くいっていません VBA初心者なのでどうか分かりやすくお教えお願い致します Sub 分別() '移動元のフォルダの設定 Const xFrm As String = "C:\before\" '移動先のフォルダの設定 Const xTo As String = "C:\after\" 'アクティブになっているシートのB列の値かつAM列の値と、C:\before内のファイルの名称が部分一致した時、そのファイルをC:\afterへと移動する '（（例）B列：M123456、AM列：789、C:\before内のファイル：M123456-789-C12.csv） Dim i As Long, xFile As String With ActiveSheet For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row With .Cells(i, 2) xFile = Dir(xFrm & "*" & .Value & "*") Do While xFile <> "" If xFile Like "*" & .Offset(, 37).Value & "*" Then Name xFrm & xFile As xTo & xFile End If xFile = Dir() Loop End With Next i End With 'C:\before内に残っているファイルを、C:\after2に移動 Dim fso As Object Dim MFir As String Dim SFir As String Set fso = CreateObject("Scripting.FileSystemObject") MFir = "C:\before\*.*" SFir = "C:\after2\" fso.MoveFile MFir, SFir →ここでエラー出る（実行時エラー53 ファイルが見つかりません） Set fso = Nothing MsgBox "終了" End Sub

  • ExcelVBAでフォルダーからファルイ名を書き出しリンクを貼り、表示名を変える

    下記のようなVBAをつくったのですがうまく行きません。 Option Explicit Dim ドライブ As String Dim フォルダ As String Dim 拡張子 As String Dim 記入シート As String Dim パス As String Dim ファイル名 As String Dim ディスプレイ As String　 Dim 貼付行 As Integer Dim ハイパーリンク As String Dim strVal As Variant 'Sub フォルダ中のファイル名をシートに書く() ドライブ = "C" 'ドライブを指定する フォルダ = "M．Co，\My Documents" 拡張子 = "*." & "JPG" 記入シート = "ファイル一覧" End Sub Private Sub 指定フォルダ中の指定拡張子のファイル名をシートに書く() Sheets(記入シート).Activate Cells.Clear 'すべてクリア Range("A1").Select パス = ドライブ & ":\" & フォルダ & "\" 'パスを組む ファイル名 = Dir(パス & 拡張子) strVal = Dir(パス & 拡張子) (1)ディスプレイ = Left(strVal, "SEARCH(""."",strVal)-1") 貼付行 = 0 　　 Do While ファイル名 <> "" 　　 貼付行 = 貼付行 + 1 Cells(貼付行, 1).Value = ファイル名 ActiveSheet.Hyperlinks.Add Anchor:=Cells(貼付行, 1), Address:=ファイル名, TextToDisplay:=ディスプレイ ファイル名 = Dir() '次のファイル名を取り出す Loop End Sub (1)がおかしいです。よろしくお願い致します。

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

    現在、以下のコードで指定フォルダー内の全ファイルをA２以下に読み込んでいます。 これでは、処理する必要のないファイルまで読み込まれてしまいます。 （そのため、現在は処理必要ないファイルは手動で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

  • .xlsファイルが存在するパスを表示させたい

    エクセルマクロ初心者です。 .xlsファイルをサブフォルダも含め検索し、A列にファイル名、B列にファイルが存在するパスを表示させるにはどうしたらいいでしょうか？検索するベースのディレクトリは決まっている”C:\temp”のでtemp以下、.xlsがどこに存在するのかを検索するマクロを組もうとしています。 いろんな書き込みを探し、サブフォルダを含め、ファイル名を取得するものは発見できたので組み込んでみましたが、、パスの表示方法がわかりません。 cnt = 0 Call Sample3("C:\temp") Callでサブルーチンsample3に渡し、ファイル名を取得しています。 　Dim cnt As Long Sub Sample3(Path As String) Dim buf As String, f As Object buf = Dir(Path & "\*.xls") Do While buf <> "" cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Loop With CreateObject("Scripting.FileSystemObject") For Each f In .GetFolder(Path).SubFolders Call Sample3(f.Path) Next f End With End Sub あとは、どのように書けばいいのでしょうか？ 宜しくお願い致します。

  • ファイル名を合成すると検索できないのでしょうか？

    下記のような式がありまして、一度作成したファイルは上書きされないはずですが何回やっても上書きされてしまいます。 これはファイルを検索していないのでしょうか？ 既にファイルがあったら終了するはずですが何か間違えていますか？ 'ファイル作成 Sub MakeCopyFile(newfile As String, orgfile As String) If SearchFile(newfile) Then Exit Sub End If Set fs = CreateObject("Scripting.FileSystemObject") fs.CopyFile orgfile, newfile End Sub ' ファイル検索 Function SearchFile(fname As String) As Boolean SearchFile = False Set fs = Application.FileSearch With fs .Filename = fname If .Execute() > 0 Then SearchFile = True End If End With End Function Sub Macro1() Dim name As String '名前 Dim fname As String 'ファイル名 Dim directory As String '作成先ディレクトリ Dim fullpath As String 'フルパス Dim orgfile As String '雛形のファイル名 Dim editbook As Workbook '個人データブック Dim id As String '番号 directory = "H:\test\" orgfile = "H:\test\雛形.xls" For i = 1 To 100 name = ThisWorkbook.Worksheets("Sheet2").Cells(i, 10).Value id = ThisWorkbook.Worksheets("Sheet2").Cells(i, 12).Value If name = "" Then Exit For End If 'コピーしたファイルを作成する fname = name + id + ".xls" 'ファイル名合成 fullpath = directory + fname 'フルパス合成 Call MakeCopyFile(fullpath, orgfile) 'ファイル作成 Workbooks.Open Filename:=fullpath Set editbook = Workbooks(fname) editbook.Worksheets("Sheet3").Cells(8, 14).Value = name editbook.Worksheets("Sheet3").Cells(8, 10).Value = id '※(その他必要な処理があれば追加してください) editbook.Close (True) Next i End Sub

  • ファイル名のわからない複数のファイルをひとつにまとめる

    エクセル2000で以下のマクロを作成したいです。 １．フォルダ内のCSVファイルを開き、中のデータをひとつにまとめる。 （フォルダ名とファイル名、ファイル数はその時によって変わってきます。ファイル数はだいたい10個くらいです。ひとつのデータは20列50行くらいで列の項目を基準にまとめたいです。） ２．列を1列目に挿入し、2列目と3列目のデータを1列目に統合する。 ３．1列目のデータを使用し、重複を調べる。重複がある場合はどちらかひとつを削除する。（できれば4列目のデータを比較し数値が少ないほうを削除したいです。） まだ途中までですが、マクロ作成してみました。 わたしとしては、フォルダ内のCSVファイルを開いてセルA1からデータの入った範囲をコピーし、testエクセルファイルのアクティブセルに貼り付け ↓↓↓ 次のファイルのデータをその下に貼り付けたいのでtestファイルのデータが入ったセルの下を選択し、ファイルを開くへ繰り返し。 のつもりなのですが…、うまく作動しません。 マクロのテキストを片手にネットでも検索しながら作ったのですが、まだ記述の仕方などがわかってなくどこがおかしいのかもわかりません。 わかる方がいたらよろしくお願いします！ ----------------------------------- Sub ファイルのデータを統合() Dim filename As String Dim openedbook As Workbook Dim isbookopen As Boolean Dim myworksheet As Worksheets Dim myrange As Range filename = Dir(ThisWorkbook.Path & "\*.csv") Do While filename <> "" isbookopen = False For Each openedbook In Workbooks If openedbook.Name = filename Then isbookopen = True Exit For End If Next Range("A1").CurrentRegion.Copy Destination:=Workbooks("test.xls").Worksheets("sheet1").ActiveCell Workbooks("test.xls").Worksheets("sheet1").Range("A1").End(xlDown).Offset(1).Select If isbookopen = False Then Workbooks.Open (ThisWorkbook.Path & "\" & filename) End If filename = Dir() Loop End Sub

  • セルの選択について

    <Sheet2のコード> Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not UserForm3.Visible Then UserForm3.Show 0 UserForm3.TextBox1.Text = Selection.Count End Sub *********************************************** <UserForm3のコード> Private Sub CommandButton1_Click() With Selection .MergeCells = True .WrapText = True .Value = TextBox2.Text　& ComboBox1.Text End With UserForm3.Hide End Sub ---------------------------------------------- Private Sub UserForm_Initialize() Dim lastrw As Integer, lastrw2 As Integer, i As Integer lastrw = Sheet3.Range("A1").End(xlDown).Row lastrw2 = Sheet3.Range("B1").End(xlDown).Row If Sheet2.Range(Cells(5, 4), Cells(5, 100)).Select Then　・・・(1) For i = 1 To lastrw - 1 ComboBox1.AddItem Sheet3.Cells(i + 1, 1).Value Next i End If If Sheet2.Range(Cells(6, 4), Cells(6, 100)).Select Then　・・・(2) For i = 1 To lastrw2 - 1 ComboBox1.AddItem Sheet3.Cells(i + 1, 2).Value Next i End If End Sub ************************************************* ワークシート上でマウスで選択されたセルの行ごとにUserForm3のComboBox1で表示させる文字を変えたいのですが、どのようにすればよいのでしょうか。 上の(1)(2)だととマウスで選択されたセルではなく(1)(2)の範囲のセルが結合されてしまいます。。。 また、今はワークシート上でマウスを左クリックする度にUserForm3が表示されてしまいます。 これをワークシート上でマウスでセルを選択して右クリックするとUserForm3が表示される ようにしたりすることは可能なのでしょうか。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する