エクセルVBAでフォルダ内の重複ファイルを表示

前へ 次へ
このQ&Aのポイント
  • フォルダ内には集計用マクロファイルと個々人用の複数の回答ファイルがあります。
  • 回答ファイルには重複ファイルが含まれる場合があり、処理を中断したいです。
  • VBAコードを修正して、重複ファイルの表示を改善したいです。
回答を見る
  • ベストアンサー

エクセルVBAでフォルダ内の重複ファイルを表示

したいのです。 フォルダ内に集計用マクロファイルと個々人用の複数の回答ファイルがあります。 回答ファイル名は、「AB1234.xls」と数字（ID）の部分は個々人で異なります。 集計用マクロファイルには、個々人のIDが記載されており、「*1234*.xls」とワイルドカードで集計する様にしています。 回答ファイルには「AB1234.xls」、「AB1234rev1.xls」、「AB1234rev2.xls」等が有る場合があり、集計前に重複ファイルを検索して処理を中断したいのです。 コードは下記の通りですが、重複ファイルのメッセージ表示が次の様になってしまいます。 AB1234.xls AB1234rev1.xls AB1234.xls AB1234rev2.xls AB5678.xls AB5678rev1.xls この表示を次の様にしたいのですが、どう手直しすれば宜しいでしょうか。 宜しくご回答願います。 AB1234.xls AB1234rev1.xls AB1234rev2.xls AB5678.xls AB5678rev1.xls ------------------------------------ ThisWorkbook.Sheets(strMonth).Activate　'マクロファイルのシート名は４月～３月の１２枚です。 MaxRow = Range("B4").End(xlDown).Row　'B4から下方に個々人のIDが記載されています。 For Y3 = 4 To MaxRow strID = Cells(Y3, 2) Cells(1, 6) = "プリチェック中" i = 0 Target = Dir(ThisWorkbook.Path & "\" & "*" & strID & "*.xls", vbNormal) msg1 = Target Do While Target <> "" i = i + 1 If i = 1 Then GoTo Label2 If i >= 2 Then msg2 = msg2 & vbCrLf & vbCrLf & msg1 & vbCrLf & Target Flag = Flag + 1 'ElseIf i = 1 Then 'msg1 = "" End If Label2: Target = Dir() Loop Next Y3 If Flag >= 1 Then Cells(1, 6) = "" msg1 = "下記のファイルが重複しているので処理を中止します。" & msg2 MsgBox msg1 Exit Sub Else End If

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

  • ベストアンサー
  • luka3
  • ベストアンサー率74% (299/401)
回答No.2

自分なりに整理して書き直してみました。 ThisWorkbook.Sheets(strMonth).Activate 'マクロファイルのシート名は４月～３月の１２枚です。 MaxRow = Range("B4").End(xlDown).Row 'B4から下方に個々人のIDが記載されています。 msg1 = "" For Y3 = 4 To MaxRow 　strID = Cells(Y3, 2) 　Cells(1, 6) = "プリチェック中" 　Target = Dir(ThisWorkbook.Path & "\" & "*" & strID & "*.xls", vbNormal) 　msg2 = "" 　i = 0 　 　Do While Target <> "" 　　i = i + 1 　　msg2 = msg2 & Target & vbCrLf 　　Target = Dir() 　Loop 　If i > 1 Then msg1 = msg1 & msg2 & vbCrLf Next Y3 If msg1 <> "" Then 　Cells(1, 6) = "" 　MsgBox "下記のファイルが重複しているので処理を中止します。" & vbCrLf & msg1 　Exit Sub End If

mayu1992
質問者

お礼

luka3さま ご回答ありがとうございます。 コードをコピペして、期待通りの結果でした♪ 整理（整然）された読みやすいコードのご回答で助かりました。 コードを見て感動しました！ またご回答くださいませ♪＜（＿　＿）＞

その他の回答 (1)

  • ap_2
  • ベストアンサー率64% (70/109)
回答No.1

> msg2 = msg2 & vbCrLf & vbCrLf & msg1 & vbCrLf & Target ファイル検出する度に、msg1（最初のファイル）と Target（検出したファイル）追加してますよね。2つめの時だけmsg1追加するとか・・・ 　if i = 2 Then msg2 = msg2 & vbCrLf & vbCrLf & msg1 　msg2 = msg2 & vbCrLf & Target > 'msg1 = "" 試行錯誤の跡？もう一息がんばってほしかった（－－；

mayu1992
質問者

お礼

ap_2さま 深夜のご回答ありがとうございます。 先のコード作成に３時間、ご察しの通り試行錯誤に２時間弱。。。 何が何だか分からなくなり質問した次第です。 またご回答下さいネ♪

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

関連するQ&A

  • エクセルVBA 重複を表示したい

    エクセルVBA 重複を表示したい Ａ列で重複すると警告するコードを以下のように作成しました。 これを修正してＡ列で重複して、なおかつＢ列でも重複した場合警告するコードにしたいのです。 添付した図では「同姓同名あり、確認してください、鈴木一郎、山口」と表示したいのです。 ご教授よろしくお願いします。 Sub test() Dim myRange As Range Dim 同一flag As Boolean Dim MsgStr As String For Each myRange In Range("A2:A10") If WorksheetFunction.CountIf(Range("A2:A10"), myRange) > 1 Then If 同一flag = False Then 同一flag = True If InStr(1, MsgStr, myRange) = 0 Then MsgStr = MsgStr & myRange & vbCrLf End If End If Next If 同一flag = True Then MsgBox "同姓同名あり" & Chr(13) & _ "確認してください" & Chr(13) & _ vbCrLf & MsgStr Else End If End Sub

  • エクセルＶＢＡ　重複を表示したい2

    エクセルＶＢＡ　重複を表示したい2 以下ではたいへんお世話になりありがとうございました。 http://okwave.jp/qa/q5849885.html 上記に関連する質問をさせていただきます。 下記に提示したコードを修正して、以下のようなコードに変えたいと考えています。 「Ｂ列で重複したデータがあれば、そのすべてを左隣のデータと一緒に表示したい」 添付した図だと、 1小沢一郎 7〃 8〃 4鈴木一郎 6〃 以上のような感じです。 アドバイスよろしくお願いします。 Sub TEST() Dim myRange As Range Dim 同一flag As Boolean Dim MsgStr As String m_Rows = Range("b" & Rows.Count).End(xlUp).Row For Each myRange In Range("b2:b" & m_Rows) If WorksheetFunction.CountIf(Range("b2:b4000"), myRange) > 1 Then If 同一flag = False Then 同一flag = True If InStr(1, MsgStr, myRange) = 0 Then MsgStr = MsgStr & myRange.Offset(0, -1).Value & myRange & vbCrLf End If End If Next If 同一flag = True Then MsgBox "同姓同名あり" & Chr(13) & _ "確認してください" & Chr(13) & _ vbCrLf & MsgStr Else End If End Sub

  • VBAによるカレントフォルダのファイルを検索し開く

    カレントフォルダ内にファイル(コ―ド.xls)を見つけ開き、無ければＭＳＧ表示したい。 どのように、したらいいですか？ 考えているのは、 Application.DefaultFilePath = ThisWorkbook.Path If ??? Then Workbooks.Open "コード.xls" else msgbox (ThisWorkbook.Path & "にコード.xlsを置いて下さい。") Exit sub end If です。 この？？？の部分を教えて頂きたいと思います。 よろしくお願いします。

  • ＶＢＡの記述で、あるシートを別ファイルにした場合

    エクセル2002で、商品を管理しています。 １列目に品番をいれると、２列目に品名が表示するようにし、 新規の品番は品名を入れると、追加登録されるようにＶＢＡを組みました。 今度、このシート"商品"を別ファイル(商品.xls)にしたいと思うのですが、 どうしても、やり方が分かりません。 よろしくお願いします。 Public Sub Worksheet_Change(ByVal Target As Excel.Range) Dim 品番 As String Dim 品名 As String Dim i As Long With Target If .Column = 1 Then 品番 = .Text For i = 1 To 65536 If Sheets("商品").Cells(i, 1) = "" Then ActiveSheet.Cells(.Row, 2) = "" Exit For ElseIf 品番 = Sheets("商品").Cells(i, 1) Then ActiveSheet.Cells(.Row, 2) = Sheets("商品").Cells(i, 2) Exit For End If Next i End If If .Column = 2 Then 品名 = .Text 品番 = ActiveSheet.Cells(.Row, 1) If 品名 = "" Or 品番 = "" Then Else For i = 1 To 65536 If Sheets("商品").Cells(i, 1) = "" Then Sheets("商品").Cells(i, 1) = 品番 Sheets("商品").Cells(i, 2) = 品名 Exit For ElseIf 品番 = Sheets("商品").Cells(i, 1) Then Exit For End If Next i End If End If End With End Sub

  • もしも新規Excelファイルを開いてる場合は閉じる

    Excel2003です・ ユーザーが新規Excelファイル（book1)かテスト用ファイルを開いている場合は閉じる処理を考えております。 Option Explicit Dim ws As Workbook, flag As Boolean Private Sub Workbook_Open() For Each ws In Workbooks If ws.Name = "Book1" Then flag = True Next ws If flag = True Then Workbooks("Book1.xls").Close 　 Else 　 End IF For Each ws In Workbooks If ws.Name = "テスト用.xls" Then flag = True Next ws If flag = True Then Workbooks("テスト用.xls").Close 　 Else 　 End IF End Sub このコードだとBook1を開いているのに、Trueで拾ってくれません。 ws.Name = "Book1.xls"にしても同じです。 どこかおかしい部分があるのでしょうか？

  • ２つのVBAを組み合わせる方法

    お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range)　 Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？

  • 【Excel VBA 2010】空白セルの検索

    ある範囲の中から書式設定も文字も入っていないセルを選んできて、 それらには何も入力がされていないという警告を出そうと考えています。 Dim k As Integer Dim msg As String Dim 空欄() As Variant k = 0 msg = " " For i = 1 To 10 For j = 1 To 10 If Cells(i , j) = Cells(i , j).SpecialCells(xlCellTypeBlanks) Then ReDim Preserve 空欄(k) As Variant 空欄(k) = Cells(i , j).Address k = k + 1 End If Next Next If 空欄(k) <> " " Then For i = 0 To k - 1 msg = 空欄(i) & vbCrLf Next MsgBox (msg & "が入力されていません。") Else ・ ・ ・ と続くのですが、上記のコードでエラー(型が一致しない)が起きます。 素人のため原因がわからないので、どなたか修正をお願いいたします。

  • エクセル　VBA　読み取り専用になっているファイルを開く場合

    エクセルVBAを取り組んでいるのですが、 "A"のファイルでマクロを作動させて、"B"のファイルを開くマクロを組んでいます。 その時に誰かが"B"のファイルを開いていた場合強制的に読み取り専用で開いてしまいます。 読み取り専用で開こうとした場合には、マクロを停止させるようにしたいのですが、どういう形にしたら良いでしょうか？ ちなみに"B"ファイルを開いているマクロを下に乗せておきますので、変更しなければならない等がありましたら、教えていただけますと幸いです。 For Each wb In Workbooks If InStr(wb.Name, "B") > 0 Then flag = True Next wb If flag = True Then Else Workbooks.Open Filename:="Z:\B.xls" End If

  • 複数フォルダに格納されたファイル名取得VBA

    お世話になっております。 あるフォルダに複数のフォルダが格納されており、更にそのフォルダの中にあるファイルの情報を取得するプログラムを書いたのですが、実行すると下記のようなエラーとなってしまいます。 ■エラー プロシージャの呼び出し、または引数が不正です 下から3行目、「buf = Dir()」が問題であることはわかるのですが、 何が問題でどのように解決したらいいかわかりません。 どなたかご教授の程よろしくお願い致します(>_<) ------------------------------------------------------------------------ Sub test() Dim buf As String Dim fName As String Dim msg As String buf = Dir("*.*", vbDirectory) Do While buf <> "" If GetAttr(buf) And vbDirectory Then If buf <> "." And buf <> ".." Then fName = Dir(CurDir & "\" & buf & "\" & "*.jpg") Do While fName <> "" cnt = cnt + 1 Cells(cnt, 1) = buf Cells(cnt, 2) = fName msg = msg & buf & "\" & fName & vbCrLf fName = Dir() Loop MsgBox msg End If End If buf = Dir() Loop End Sub ------------------------------------------------------------------------ これが実現できないと細かい作業を毎日繰り返す事となり、 かなり業務不可が高いです。。 繰り返しになってしまいますが、どなたかご回答よろしくお願い致します。

  • 小数点以下表示

    averageで計算した値を表示したところ、 勝手に四捨五入されてしまいました 小数点第二位まで表示したいので どなたかよろしくお願いいたします<m(__)m> Option Explicit Public Sub 平均() Const SH_NAME As String = "VBA" Dim art As String Dim i Dim ws As Worksheet Dim endrow As Long Dim msg As String Dim writerow As Integer Dim target As Range Dim ActCell As Variant Dim Result As Integer Set ws = ThisWorkbook.Worksheets(SH_NAME) writerow = 2 art = InputBox("日付を入力してください") With ws endrow = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To endrow If art = .Range("A" & i) Then If target Is Nothing Then Set target = Range("D" & i) Else Set target = Union(target, Range("D" & i)) End If Else If InStr(msg, .Range("A" & i)) = 0 Then msg = msg & .Range("A" & i) & vbCrLf End If End If Next i If msg <> "" Then MsgBox msg End If target.Select ActCell = Selection.Address Result = Application.WorksheetFunction.Average(.Range(ActCell)) Range("F39").Value = Result Range("F39").NumberFormatLocal = "0.00" End With End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する