【EXCEL2010 VBA】同名ファイルチェック

前へ 次へ
このQ&Aのポイント
  • 医療系入院マクロを作っています。特定の場所にある原本1.xlsmファイルをリネームしてコピーするマクロです。
  • 同名のファイルが存在する場合にエラーが出ます。存在した場合にはファイル名の語尾に2つずつ付けていきます。
  • 移動先に3つの場所で同名ファイルチェックが必要ですが、難解なため断念しました。お手数をおかけします。
回答を見る
  • ベストアンサー

【EXCEL2010 VBA】同名ファイルチェック

医療系入院マクロを作っています。下記はUserForm3上のCommandButton2をクリックすると特定の場所にある原本1.xlsmをUserForm3.TextBox13(患者名)にリネームして特定の場所へコピーするマクロです。 Private Sub CommandButton2_Click() Dim cnsSOUR2 As String, cnsORSL As String, cns2FSO2 As String, cns4FSO2 As String cnsORSL = ThisWorkbook.Path & "\..\メンテナンスフォルダ\インストールフォルダ\原本1.xlsm" cnsSOUR2 = ThisWorkbook.Path & "\看護情報フォルダ\" & UserForm3.TextBox13 & ".xlsm" cns2FSO2 = ThisWorkbook.Path & "\..\2Fカーデックス\看護情報フォルダ\" &　UserForm3.TextBox13 & ".xlsm" cns4FSO2 = ThisWorkbook.Path & "\..\4Fカーデックス\看護情報フォルダ\" & UserForm3.TextBox13 & ".xlsm" FileCopy cnsORSL, cnsSOUR2　'　ここでリネーム&移動 End Sub しかし移動先に同名ファイルが存在する場合にエラーが出てしまいます。そこで If Dir(cnsSOUR2) <> "" Then If Dir(cns2FSO2) <> "" Then If Dir(cns4FSO2) <> "" Then などで同名が存在してることが分かった場合、UserForm3.TextBox13(患者名)の語尾に2とつけて、 上記も同名が存在してることが分かった場合、UserForm3.TextBox13(患者名)の語尾に3とつけて… を99まで繰り返したいです。※(転棟の都合により)cnsSOUR2、cns2FSO2、cns4FSO2の複数の場所で同名ファイルチェックが必要になります。 難解のため、断念いたしました。お手数ですが何卒よろしくお願いします。

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

  • ベストアンサー
回答No.1

フォルダ名と基本ファイル名から、重複しないファイル名を検索して返す関数です。 バージョン番号を1から順に増やしてファイル名を作成し、存在しないファイル名を返します。 Private Function GetNewVersionFile(fDir As String, fBase As String) As String 'fDir フォルダのパス名（￥マークの終端） 'fBase 基本ファイル名（拡張子なし） Dim fVer As Integer Dim fName As String '検索するファイル名 Dim swork As String fVer = 1 Do If fVer = 1 Then fName = fBase & ".xlsm" Else fName = fBase & CStr(fVer) & ".xlsm" End if swork = Dir(fDir & fName) If swork="" Then Exit Do fVer = fVer + 1 Loop GetNewVersionFile = fName End Function

usny-stk
質問者

お礼

上記参考させてもらい別の方法で乗り切りました。アドバイスありがとうございました！

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

関連するQ&A

  • 【Excel2010 VBA】同名ファイルチェック

    医療系マクロを作っています。下記はUserForm3上のCommandButton2をクリックすると特定の場所にある原本1.xlsmをUserForm3.TextBox13(患者名)にリネームして特定の場所へコピーするマクロです。 Private Sub CommandButton2_Click() Dim cnsSOUR2 As String, cnsORSL As String, cns2FSO2 As String, cns4FSO2 As String cnsORSL = ThisWorkbook.Path & "\..\メンテナンスフォルダ\インストールフォルダ\原本1.xlsm" cnsSOUR2 = ThisWorkbook.Path & "\看護情報フォルダ\" & UserForm3.TextBox13 & ".xlsm" cns2FSO2 = ThisWorkbook.Path & "\..\2Fカーデックス\看護情報フォルダ\" &　UserForm3.TextBox13 & ".xlsm" cns4FSO2 = ThisWorkbook.Path & "\..\4Fカーデックス\看護情報フォルダ\" & UserForm3.TextBox13 & ".xlsm" FileCopy cnsORSL, cnsSOUR2　'　ここでリネーム&移動 End Sub しかし移動先に同名ファイルが存在する場合にエラーが出てしまいます。そこで If Dir(cnsSOUR2) <> "" Then If Dir(cns2FSO2) <> "" Then If Dir(cns4FSO2) <> "" Then などで同名が存在してることが分かった場合、UserForm3.TextBox13(患者名)の語尾に2とつけて、 上記も同名が存在してることが分かった場合、UserForm3.TextBox13(患者名)の語尾に3とつけて… を99まで繰り返したいです。※(転棟の都合により)cnsSOUR2、cns2FSO2、cns4FSO2の複数の場所で同名ファイルチェックが必要になります。 難解のため、断念いたしました。お手数ですが何卒よろしくお願いします。

  • VBA：2つのCSVファイルを開きたいです。

    エクセル2010のVBAにてCSVファイルを開き結合させるプログラムを組もうとしているのですが、2つ目のCSVファイルを開こうとすると、何故かエラーが出てしまいます。 -------------------------------------------------------------------------------- 1つ目 Sub mobile_FileSearch(Path As String) 'test.csvのデータを検索して開く Dim FSO As Object, Folder As Variant, File As Variant Set FSO = CreateObject("Scripting.FileSystemObject") For Each Folder In FSO.GetFolder(Path).SubFolders Call mobile_FileSearch(Folder.Path) Next Folder For Each File In FSO.GetFolder(Path).Files If File.Name = "test.csv" Then Workbooks.Open ("test.csv") End If Next File End Sub ---------------------------------------------------------------------------- 2つ目 Sub local_FileSearch(Path As String) 'bbb.csvのデータを検索して開く Dim FSO As Object, Folder As Variant, File As Variant Set FSO = CreateObject("Scripting.FileSystemObject") For Each Folder In FSO.GetFolder(Path).SubFolders Call local_FileSearch(Folder.Path) Next Folder For Each File In FSO.GetFolder(Path).Files If File.Name = "bbb.csv" Then Workbooks.Open ("bbb.csv")'←ここでエラー End If Next File End Sub ------------------------------------------------------------------------ まったく同じプログラムで、csvファイル名だけ変えただけで実行時エラー1004が出てしまいます。 一体全体何が問題なのでしょうか？

  • ＥＸＣＥＬ－ＶＢＡで質問です

    いつもお世話になります。ＥＸＣＥＬ－ＶＢＡで質問です。 メーカー別・品番別に部品図を管理しており、それをＥＸＣＥＬでデータベース化しています。 ユーザーフォームを作成し、検索＆新規入力が出来るようになっておりますが、今回は更にTextBox1に入った品番の該当ファイルを選択した状態で、フォルダを開くようにしたいでのです。 フォルダ構成は、「￥Ａ社￥品番の頭文字￥品種￥ファイル名」が基本となっており、品種フォルダはない場合もあります。 Ａ社￥Ａ￥ＡＡＡ￥ＡＡＡ１ｘ３ 　　　　〃　　　￥ＡＡＡ１ｘ５ 　　　　￥ＡＡＡＢ￥ＡＡＡＢ１ｘ１０… Ｂ社￥１￥１Ａ１Ｂ２０＿２５０ 〃　￥Ｂ￥ＢＣ￥ＢＣ１０ｘ３００… このような感じです。品番は英数半角です。 ユーザーフォームのTextBox1には品番が、TextBox3にメーカー名が入るようになっています。 一応、自分で努力はしてみたのですが、品番の頭文字のフォルダを開くことはできましたが、それ以降は動いてくれませんでした。 Private Sub CommandButton3_Click() Dim openpath As String Dim opn As String Dim openmaker As String Dim openfolder As String Dim opensubfolder As String Dim openfile As String Dim i As Long openpath = ThisWorkbook.Path openmaker = TextBox3 openfolder = Left(TextBox1, 1) openfile = TextBox1 & "*" ←拡張子が多数あるので、ワイルドカードにしたいです For i = 1 To 8 ※８というのは適当です。本当は左からアルファベットの文字を数えてループさせようとしたのですが、できませんでした。頭文字が数字の場合はどうすればいいのかも不明… If Mid(TextBox5, i, 1) Like "[A-Za-z]" Then opensubfolder = Left(TextBox1, i) ※品種フォルダがない場合はどうすればいいのでしょうか… End If Next opn = openpath & "\" & "メーカー別" & "\" & openmaker & "\" & openfolder & "\" & opensubfolder 　 Shell "Explorer /select, & opn & openfile", 1 End Sub お手数ですが、宜しくご教示お願い致します。

  • vbaで新規フォルダ作成時の名前の指定

    「あいいうえお」フォルダの中に年が変わったら「2015年」という名前でフォルダの作成を行いたいのですが、下記のコードでは「あいうえお2015年」という名前のフォルダを作成してしまいます。フォルダの作成で、「あいうえお」を除いたものを作成するにはどう変えればよいでしょうか？ （12月のファイルで実行した時に例えば「2015年」フォルダを作成して、その中に「あいうえお2015-1月.xlsm]ファイルを作成します。同じ年なら「あいうえお11月.xlsm]などファイルのみを作成します。） お手数をおかけしますがどうぞよろしくお願いいたします。 Sub ブックコピー自動翌月分作成() Dim i As Integer Dim wb As Workbook Dim myDir_path As String, myNew_path As String 'フォルダパスとファイルパスを作成 myDir_path = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 1) myNew_path = "あいうえお" & Format(DateAdd("m", 1, Replace(Replace(ThisWorkbook.Name, "あいうえお", ""), "月.xlsm", "")), "yyyy-m") & "月.xlsm" myDir_path = Left(myDir_path, InStrRev(myDir_path, "\")) & Left(myNew_path, 9) & "年\" 'フォルダの有無を確認、なければ作成 With CreateObject("Scripting.FileSystemObject") If Not .FolderExists(myDir_path) Then MkDir myDir_path 'MsgBox myDir_path & "を作成しました" 'MsgBox Left(myDir_path, InStrRev(myDir_path, "\")) & "に" & vbNewLine & MsgBox Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 12) & "に" & vbNewLine & _ Left(myNew_path, 9) & "年" & "フォルダを新たに作成しました" End If End With 'ファイルの有無を確認、なければ保存,あれば処理中止 If Dir(myDir_path & myNew_path) = "" Then ThisWorkbook.SaveCopyAs myDir_path & myNew_path MsgBox myNew_path & "のファイルを新たに作成しました" Else MsgBox "翌月分のファイルはすでに存在するので処理を中止します", vbOKOnly, "処理中止" Exit Sub End If '新規作成したブックを開く,既に開いていれば処理中止 For Each wb In Workbooks If wb.Name = myNew_path Then MsgBox myNew_path & "は既に開いているので処理を中止します", vbOKOnly, "処理中止" Exit Sub End If Next Workbooks.Open myDir_path & myNew_path Workbooks(myNew_path).Activate End Sub

  • Excel2007で拡張子xlsmのブックを保存

    Excel2007でマクロ作成の初心者です。 以下のコードを実行させると、月次24年5月.xlsm-4143というブックができてしまいます。 そして開くこともできません。 どうしたら、月次24年5月.xlsm　というブックにできるのでしょうか。 Sub データの保存() Dim Path As String, WSH As Variant Set WSH = CreateObject("WScript.Shell") Path = WSH.SpecialFolders("Desktop") & "\常用\H24年データ\月次" '和暦の年月で編集する Path = Path & Format(Date, "ee年m月") & ".xlsm" & Excel.xlWorkbookNormal '存在しない場合のみ作成する If Dir(Path) = "" Then ThisWorkbook.SaveAs Path End If Set WSH = Nothing End Sub

  • （VBA)　同名フォルダーの存在をチェック

    以下のコード（Sub ⑤フォルダー名の変更()）でフォルダー名の変更を行っています。 変名時に同名ファイルがある場合エラーが以下のコードでエラーがでます。 　　.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text エラー無く処理したいので 　同名があるばあいは、フォルダー名の末尾に（1）、(2)を付加したいのですが 　同名があるかどうかは？どのように判定しますか　？ Sub ⑤フォルダー名の変更() Dim i As Long Dim LastColumn As Single Dim LastColumn_ABC As String Dim MSG As String LastColumn = Cells(5, "B").End(xlToRight).Column LastColumn_ABC = Split(Cells(1, LastColumn).Address, "$")(1) MSG = MsgBox("B列フォルダー名が" & LastColumn_ABC & "列フォルダー名に変更されます！" & vbCrLf _ & "B," & LastColumn_ABC & "列に値がなければ、処理は行いません。", 257, "フォルダー名変更") If MSG = vbCancel Then Exit Sub i = 5 'subフォルダ名取得が5行目からフォルダー名を表示するため。 Do While Range("b" & i).Text <> "" If Cells(i, LastColumn).Text <> "" Then ' 新フォルダー名がある場合のみ、名前変更を行う。 With CreateObject("Scripting.FileSystemObject") .GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text End With End If i = i + 1 Loop MsgBox "変名処理が終了しました。" End Sub

  • VBA　フォルダ内ファイルにマクロ一括処理

    フォルダ内ファイルのマクロを一括実行したいです。 フォルダ内ファイル全てに下記のマクロを登録 Sub 値貼り付け() 'シート4番目を選択 Sheets(4).Select 'シート名1文字目が「★」以外のシートを選択 For Each i In ThisWorkbook.Sheets If Not i.Name Like "★*" Then i.Select Replace:=False End If Next i '全セル選択 Cells.Select 'コピー Selection.Copy '値貼り付け Selection.PasteSpecial Paste:=xlPasteValues Cells(1, 1).Select Sheets(1).Select '「.xlsx」で保存 Application.DisplayAlerts = False Dim fso, f Set fso = CreateObject("Scripting.FileSystemObject") With ActiveWorkbook f = fso.GetBaseName(.Name) .SaveAs .Path & "\" & f & "保存.xlsx", FileFormat:=xlWorkbookDefault .Close End With Set fso = Nothing End Sub 一括でマクロを実行する用のファイルに下記マクロを登録 Sub 一括処理() Dim Fpath As String Dim Fname As String Dim Wb As Workbook Fpath = ThisWorkbook.Path & "\" Fname = Dir(Fpath & "*.xlsm") Do Until Fname = "" If Fname = ThisWorkbook.Name Then Else Application.DisplayAlerts = False 'ブックを開く Set Wb = Workbooks.Open(Fpath & Fname) 'マクロ実行 Application.Run "'" & Fname & "'!値貼り付け" Wb.Close SaveChanges:=True Application.DisplayAlerts = True End If Fname = Dir() Loop End Sub 一括処理の実行をすると、フォルダ内の一つのファイルだけ マクロ実行されると終了してしまいます。 各々のファイルには他にもマクロを登録していて、そちらは 'マクロ実行 Application.Run "'" & Fname & "'!値貼り付け" のマクロの名前部分を変更して、同様に一括処理していますが 問題なく動きます。 なぜかこの「値貼り付け」のマクロだけ全ファイルに動作して くれません。 色々自分なりに調べているのですが、どうしても原因不明で 今回投稿させて頂きました

  • vba　ファイルの移動について

    フォルダAの中にあるたくさんのpdfファイルの中から、 ファイル名の頭文字３つがE列に記載した「aaa」だったら フォルダBに移動させるという内容にしたいです。 ネット検索などで、近いものを作成しましたが（下に貼り付け）、 下から４行目、「fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName」で 「実行時エラー'53'　　ファイルが見つかりません。」　とエラーが出てしまいます。 どの様に書き直せばよいのでしょうか？ どなたかご存じでしたら、ぜひお教え下さい。 よろしくお願いします。 エクセル2010を使用しています。 Sub CheckAndMoveFiles() Dim FolderA As String Dim FolderB As String FolderA = Range("D1").Value FolderB = Range("B2").Value Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("E" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "E").Value <> "" Then fileName = ws.Cells(r, "E").Value dFileName = Dir(FolderA & "\" & Left(fileName, 3) & "*.pdf") Do While dFileName <> "" dFileName = Dir() Loop fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName　'ここでストップ End If Next End Sub

  • FSOを使いサブフォルダのファイル操作

    同じ階層のサブフォルダにxlsm入るが入っており、VBAによりモジュールを解放しようと試みています。 まずは、FSOを使ってサブフォルダにアクセスしようとしましたが、下から6行目でエラー（424 オブジェクトが必要です）が出てしまい、解決できませんので、ご教示いただけないでしょうか？ よろしくお願いします Sub DeleteMain() With Application.FileDialog(msoFileDialogFolderPicker) If Not .Show Then Exit Sub Call DeleteSub(folderPath:=.SelectedItems(1)) End With End Sub Sub DeleteSub(folderPath As String, Optional mycount As Long = 0) Dim fso As Object, myFolders As Object, myfile As Object Set fso = CreateObject("Scripting.FileSystemObject") Set myFolders = fso.GetFolder(folderPath).SubFolders For Each myfile In fso.GetFolder(folderPath).Files mycount = mycount + 1 ' Cells(mycount, 1) = myfile.Path Debug.Print myfile.Path Next For Each myFolders In fso.GetFolder(folder.Path).SubFolders Call DeleteSub(myFolder.Path, mycount) Next Set fso = Nothing Set myFolders = Nothing End Sub

  • VBAでファイルを消したい

    こんばんわ！ VBAでエクセルファイルをバックアップしながら使用しているのですが、１０個以上ファイルが溜まったら一番古いものを消したいです。 途中まではできているのですが、古いファイルを選択する方法が分かりませんToT 途中までのソースを乗せますので、アドバイスの程よろしくお願いいたします。 ===＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ Private Sub backup_bot_Click() Dim Path As String, WSH As Variant Dim fc As Long Dim fn As String 'マイドキュメントにバックアップ Set WSH = CreateObject("WScript.Shell") Path = WSH.SpecialFolders("MyDocuments") & "\test" If Dir(Path, vbDirectory) = "" Then MkDir (Path) End If 'ファイルコピー FileCopy "c:test_date\aaa.xls", Path & "\aaa" & Format(Now, "yyyymmdd") & ".xls" 'ファイル数確認 fn = Dir(Path & "\aaa*.xls") Do While fn <> "" fc = fc + 1 fn = Dir() Loop '10件以上消去 If fc > 10 Then 'ここが分かりません！ End If End Sub ===＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ あ～ちなみにoffice2003エクセルを使用しています。 XP以降のOSで動かしたいです！

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する