Private Sub CreateReport_Mp3FileProperties()
    Dim iFileName$, iPath$, iRow&, iColumn&
    Dim iFolder As Object, iMp3File As Object
        
    iPath = "C:\Мои документы\Downloads\mp3_tracks\": iRow = 2
    
    Set iFolder = CreateObject("Shell.Application").NameSpace(CVar(iPath))
    If Not iFolder Is Nothing Then
       iFileName = Dir(iPath & "*.mp3")
       If iFileName <> "" Then
          Workbooks.Add xlWBATWorksheet
          Application.ScreenUpdating = False
          Do
               Application.StatusBar = iFileName
               Set iMp3File = iFolder.ParseName(iFileName)
               For iColumn = 0 To 50 '
                   Cells(iRow, iColumn + 1) = iFolder.GetDetailsOf(iMp3File, iColumn)
               Next
               iFileName = Dir
               iRow = iRow + 1
          Loop While iFileName <> ""
          For iColumn = 0 To 50 ' Headers Report
              Cells(1, iColumn + 1) = iFolder.GetDetailsOf(iFolder.Items, iColumn)
          Next
          Application.StatusBar = False
          Application.ScreenUpdating = True
       Else
          MsgBox "Нет музыкальных файлов .mp3", , ""
       End If
    Else
       MsgBox "Папка, а стало быть и файл(ы), отсутствуют", , ""
    End If
End Sub

Private Sub CreateReport_Mp3FileProperties2()
    Dim iPath$, iMp3Property$(), iCountFiles&, iRow&, iColumn&
    Dim iFolder As Object, iFolderItems As Object, iMp3File As Object
        
    iPath = "C:\Мои документы\Downloads\mp3_tracks"
    
    Set iFolder = CreateObject("Shell.Application").NameSpace((iPath))
    If Not iFolder Is Nothing Then
    
       Set iFolderItems = iFolder.Items
       iFolderItems.Filter 64 + 128, "*.mp3"
       
       iCountFiles = iFolderItems.Count
       If iCountFiles > 0 Then
       
          ReDim iMp3Property(iCountFiles - 1, 50)

          Application.ScreenUpdating = False
          Workbooks.Add xlWBATWorksheet
 
          For iColumn = 0 To 50 ' Headers Report
              Cells(1, iColumn + 1) = iFolder.GetDetailsOf(iFolderItems, iColumn)
          Next
         
          For Each iMp3File In iFolderItems
              Application.StatusBar = iMp3File.Name
              For iColumn = 0 To 50 '
                  iMp3Property(iRow, iColumn) = iFolder.GetDetailsOf(iMp3File, iColumn)
              Next
              iRow = iRow + 1
          Next
          Cells(2, 1).Resize(iCountFiles, 51).Value = iMp3Property          

          Application.StatusBar = False
          Application.ScreenUpdating = True
       Else
          MsgBox "Нет музыкальных файлов .mp3", , ""
       End If
    Else
       MsgBox "Папка, а стало быть и файл(ы), отсутствуют", , ""
    End If
End Sub

Private Sub CreateReport_Mp3FileProperties4()
    Dim iArrProp As Variant, iValueProp As Variant, iRow&, iColumn&
    Dim iPath As Variant, iFileName$, iFolder As Object, iMp3File As Object
    
    iArrProp = Array( _
    "DocTitle", "Artist", "Album", "Year", "Track", "Genre", _
    "Duration", "Bitrate", "Sample Rate", "Channels", "DocComments", "Protected")
    
    Application.ScreenUpdating = False: Workbooks.Add xlWBATWorksheet
    
    iPath = "C:\Downloads\Music\MP3\" 'Укажите свою папку с .mp3 файлами
    
    Set iFolder = CreateObject("Shell.Application").NameSpace(iPath)
      
    iFileName = Dir(iPath & "*.mp3"): iRow = 2
    
    Do Until iFileName = ""
       Set iMp3File = iFolder.ParseName(iFileName)

       Application.StatusBar = iFileName: Cells(iRow, 1) = iFileName
         
       For iColumn = 0 To 11 'UBound(iArrProp)
           iValueProp = iMp3File.ExtendedProperty(iArrProp(iColumn))
                
           Select Case iColumn
               Case 7, 8
                  Cells(iRow, iColumn + 2) = iValueProp \ 1000
               Case 6
                  Cells(iRow, iColumn + 2) = Format(CDbl(iValueProp) / 864000000000#, "hh:mm:ss")
               Case Else
                  Cells(iRow, iColumn + 2) = iValueProp
           End Select
       Next
           
       iFileName = Dir: iRow = iRow + 1
    Loop
       
    With Cells(1).Resize(, 13) 'Range("A1:M1")
         .Value = Array( _
         "Имя файла", "Заголовок", "Исполнитель", "Aльбом", "Год", _
         "Номер записи", "Жанр", "Длительность", "Качество звука (кбит/сек)", _
         "Частота дискретизации (кГц)", "Каналы", "Комментарий", "Защита")
         
         .Font.Bold = True: .EntireColumn.AutoFit
    End With
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub