Dim oWs As Worksheet
Dim oCell As Object

If TypeOf Application.Selection Is Range Then
  For Each oWs In ActiveWorkbook.Windows(1).SelectedSheets
    oWs.Activate
    For Each oCell In oWs.Application.Selection.Cells
      'ひらがなに変換
      oCell.Value = StrConv(oCell.Value, vbHiragana)
      'かたかなに変換
      oCell.Value = StrConv(oCell.Value, vbKatakana)
      '大文字ひらがなに変換
      oCell.Value = StrConv(oCell.Value, vbUpperCase)
      '小文字に変換
      oCell.Value = StrConv(oCell.Value, vbLowerCase)
      '全角に変換
      oCell.Value = StrConv(oCell.Value, vbWide)
      '半角に変換
      oCell.Value = StrConv(oCell.Value, vbNarrow)
    Next oCell
  Next oWs
End If
Set oWs = Nothing

Dim IndexWsh As Worksheet
Dim Wsh As Worksheet
Dim TrgWbk As Workbook
Dim WBk As Workbook
Dim i As Long

Set TrgWbk = ActiveWorkbook

For Each WBk In Application.Workbooks
  If WBk.Name = TrgWbk.Name & "-Index" Then
    Exit Sub
  End If
Next WBk

Set WBk = Application.Workbooks.Add
Set IndexWsh = WBk.Worksheets("Sheet1")
IndexWsh.Name = TrgWbk.Name & "-Index"

i = 1

With IndexWsh
  For Each Wsh In TrgWbk.Worksheets
    If Wsh.Name <> "Indexsheet" Then
      .Hyperlinks.Add _
        Anchor:=.Cells(i, 1), Address:="", SubAddress:= _
        "'[" & TrgWbk.Name & "]" & Wsh.Name & "'!A1", _
        TextToDisplay:=Wsh.Name
      i = i + 1
    End If
  Next Wsh
End With

IndexWsh.Columns("A:A").EntireColumn.AutoFit

Set Wsh = Nothing
Set IndexWsh = Nothing
Set TrgWbk = Nothing
Set WBk = Nothing

Dim rg As Range

If "Range" = TypeName(Application.Selection) Then
  For Each rg In Application.Selection
    If Left(rg, 4) = "http" Then
      rg.Hyperlinks.Add rg, rg.Text, "", "", rg.Text
    End If
    Next
End If

Dim objOApp As Object 'Outlook.Application
Dim objNameSpace As Object 'Outlook.NameSpace
Dim objDFld As Object 'Outlook.MAPIFolder
Dim objFld As Object 'Outlook.MAPIFolder
Dim objItem As Object 'Outlook.MailItem
Dim objEApp As Object 'Excel.Application
Dim objASht As Object 'Excel.Worksheet
Dim i As Long

'複数のデータフォルダを使用している場合
Const DATAFOLDER As String = "業務用フォルダ"
'抽出対象のフォルダ名称を指定
Const SUBFOLDER As String = "受信トレイ"

Set objOApp = CreateObject("Outlook.Application")

Set objNameSpace = objOApp.GetNamespace("MAPI")

For Each objDFld In objNameSpace.Folders

  Debug.Print objDFld.Name
  
  If objDFld.Name = DATAFOLDER Then
  
    For Each objFld In objDFld.Folders
      Debug.Print objFld.Name
      If objFld.Name = SUBFOLDER Then
        Exit For
      End If
    Next objFld
    
    'objFld.Name = SUBFOLDER の判定でTrueとなったかを判定
    If Not objFld Is Nothing Then
      i = 1
      
      Set objEApp = Excel.Application
      objEApp.ScreenUpdating = False 'Excelの更新を一時的に停止
      Set objASht = objEApp.ActiveSheet
      For Each objItem In objFld.Items
        If objItem.UnRead = True Then
          objASht.Cells(i, 1) = objItem.Subject
          '本文を読み込む場合はセキュリティー関連のダイアログ
          'が表示されます。
          'objASht.Cells(i, 2) = objItem.Body
          objASht.Cells(i, 3) = objItem.ReceivedTime
          i = i + 1
        End If
      Next objItem
      objEApp.ScreenUpdating = True 'Excelの更新を再開
      Exit For
    End If
  End If
  
Next objDFld

objOApp.Quit

Set objASht = Nothing
Set objEApp = Nothing
Set objASht = Nothing
Set objItem = Nothing
Set objFld = Nothing
Set objDFld = Nothing
Set objNameSpace = Nothing
Set objOApp = Nothing