ファイルリストに拡張子だけ抜き出し

いろんなサイトの仕事をすると必ずサイトの中身の話が出てきます。まずは、ファイルリストを作って現状解析から始まるものです。

そんな時に役に立つマクロを一つ作ってみた。
EXCEL上で拡張子を切りだしてくれるマクロ

実行にはEXCELの[ALT+F8]
　 [ツール] から [参照設定]
　[Microsoft Scripting Runtime] をチェックして [OK]を設定する必要

マクロとしては下の感じです。下記の3行を書き換えれば稼働は簡単です。
EXCELの「R1C1」書式で列の番号を入力すればいい
ーーーーーーーーーーーーーーーーー
work_sheets1_st = 2 ‘シートスタート行
task_cont = 3 ‘拡張子保存　列ナンバー [ここは重要書き換えて！！
list_cont = 2 ‘ファイルリスト　列ナンバー [ここは重要書き換えて！！
ーーーーーーーーーーーーーーーーー
ボタン画像を作ってマクロを新規登録すればOK
たまには技術的なこともね・・・・

ではまた

Sub ext_get()
'[ALT+F8] [ツール] から [参照設定] 　[Microsoft Scripting Runtime] をチェックして [OK]
Dim myBook, myDir, mySheet '自ファイル　自フォルダーの設定
myBook = ActiveWorkbook.Name '自ファイルの設定
myDir = ActiveWorkbook.Path '自ファイルのフォルダー
mySheet = ActiveSheet.Name
Dim todayDate, todayDate_sec As String
todayDate = Format(Date, "yyyymmdd") ' 今日の日付を取得
todayDate_sec = Format(Date, "yyyy/m/d")
Dim i, j, ws, y, x, t, s 'for next
Dim task_cont, list_cont
'拡張子取得のための宣言
Dim fso As New Scripting.FileSystemObject
Dim filePath As String
Dim ExtentionName As String
Dim work_sheets1, work_sheets1_st, work_sheets1_ed
work_sheets1 = mySheet
work_sheets1_st = 2 'シートスタート行
task_cont = 3 '拡張子保存　列ナンバー [ここは重要書き換えて！！
list_cont = 2 'ファイルリスト　列ナンバー [ここは重要書き換えて！！
work_sheets1_ed = Workbooks(myBook).Worksheets(work_sheets1).Cells(1048576, list_cont).End(xlUp).Row '実行タスクに関する最終行
'MsgBox work_sheets_no_count
Dim Rtn
Rtn = MsgBox(Chr(10) & " filename extension GET line all" & work_sheets1_ed, vbYesNo, "選択")
If Rtn = vbYes Then
Application.ScreenUpdating = False
'================================
For y = work_sheets1_st To work_sheets1_ed
If Workbooks(myBook).Worksheets(work_sheets1).Cells(y, task_cont) = "" Then
DoEvents 'osから見放されないようにおまじない
filePath = Workbooks(myBook).Worksheets(work_sheets1).Cells(y, list_cont)
ExtentionName = fso.GetExtensionName(filePath)
Workbooks(myBook).Worksheets(work_sheets1).Cells(y, task_cont) = ExtentionName
Set fso = Nothing
End If
'If (y Mod 10) = 0 Then
'Application.ScreenUpdating = True '描画
Application.EnableEvents = True 'イベント抑制
Application.StatusBar = "処理実行中．．．．現在 [" & y & "/" & work_sheets1_ed & "]"
Application.EnableEvents = False 'イベント抑制
'Application.ScreenUpdating = False '描画停止
'End If
Next y
'Workbooks(myBook).Worksheets(work_sheets1).Activate
'================================
MsgBox "設定が完了しました"
End If 'If Rtn = vbYes Then
Application.ScreenUpdating = True
End Sub

下記に実装したサンプルを入れます。
[Microsoft Scripting Runtime] が必要です。