[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『シート名でEXCELファイルを検索』(でんで)
やりたいことに関しましては、
シート名を入力するとExcelファイルを検索し、該当シートをコピーすることです。
色々参考にし下記コードで、シートの一覧を出しコピーまでは出来たのですが
シート名で絞り込む方法が分からないです。
詳しい方お教えください。宜しくお願い致します。
下記コードです。
Sub 検索()
Dim fn(10000) 'フォルダ内ファイル名 Dim sn(10000, 2) 'フォルダ内エクセルファイル名、シート名 Dim i As Long, j As Long, k As Long, x As Long Dim myPath As String 'フォルダパス Dim ext As String '拡張子検索変数
'フォルダの選択 With Application.FileDialog(msoFileDialogFolderPicker) 'ダイアログ表示 .Title = "フォルダを選択" .AllowMultiSelect = False If .Show = -1 Then myPath = .SelectedItems(1) 'パス取得 Else Exit Sub End If End With
Application.ScreenUpdating = False '画面更新非表示
'ファイル名の取得 fn(1) = Dir(myPath & "\", vbDirectory) i = 1 Do i = i + 1 fn(i) = Dir
Loop Until fn(i) = ""
'シート名の取得 x = 0 For j = 1 To i - 1 ext = Mid(fn(j), InStrRev(fn(j), ".") + 1, 3) '拡張子取得 'エクセルファイルの時実行 If ext = "xls" Then Workbooks.Open Filename:=myPath & "\" & fn(j) For k = 1 To Sheets.Count sn(x, 1) = fn(j) 'エクセルファイル名取得 sn(x, 2) = Sheets(k).Name 'シート名取得
x = x + 1 Next k ActiveWorkbook.Close End If Next j
'シート名一覧の作成 Columns("A:B").Select Selection.ClearContents Cells(2, 1) = "作業フォルダ" Cells(3, 1) = myPath Cells(4, 1) = "ファイル名" Cells(4, 2) = "シート名" x = 0 Do Cells(x + 5, 1) = sn(x, 1) Cells(x + 5, 2) = sn(x, 2) x = x + 1 Loop Until sn(x, 1) = ""
Range("A1").Select
Application.ScreenUpdating = True '画面更新表示
MsgBox "完了しました"
End Sub
'シート名ダブルクリックすると実行
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim fn As String, bk As String, pth As String Dim ptBk As Workbook, ptBk_pth As String
If Intersect(Target, Range("B5", Cells(Rows.Count, "B").End(xlUp))) Is Nothing Then Exit Sub Cancel = True pth = Range("A3").Value bk = Target.Offset(, -1).Value fn = Target.Value
ptBk_pth = Application.GetOpenFilename("Excelブック,*.xls?") 'コピー先のブック選択
If ptBk_pth = "False" Then Exit Sub 'キャンセル時終了
Application.ScreenUpdating = False '画面更新非表示
Set ptBk = Workbooks.Open(ptBk_pth) With Workbooks.Open(pth & "\" & bk) Application.EnableEvents = False 'イベントを抑止 .Sheets(fn).Copy Before:=ptBk.Sheets(1) Application.EnableEvents = True
.Close savechanges:=False 'コピー元は保存せず閉じる End With ptBk.Close savechanges:=True 'コピー先は保存し閉じる Application.ScreenUpdating = True '画面更新表示
End Sub
< 使用 Excel:Excel2016、使用 OS:Windows10 >
(もこな2) 2021/11/29(月) 12:57
どこまで自動化したいのか分かりませんので、
日本語でフローを書いたらどうでしょう。
どなたかコード化してくれるかもしれませんよ。
(tkit) 2021/11/29(月) 15:39
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.