Sub Move_to_ABC_Folders()
    Dim FSO As Object
    Dim FromPath As String
    Dim sbFolder As Object
  
    FromPath = "R:\test"
    Set FSO = CreateObject("scripting.filesystemobject")
    For Each sbFolder In FSO.getfolder(FromPath).subFolders
            If Len(sbFolder.Name) <> 1 Then
                If FSO.FolderExists(FromPath & "\" & Left(sbFolder.Name, 1) & "\") = False Then
                   FSO.CreateFolder (FromPath & "\" & Left(sbFolder.Name, 1) & "\")
                End If
                
                sbFolder.Move FromPath & "\" & Left(sbFolder.Name, 1) & "\"
            End If
        Next sbFolder
End Sub

Sub Move_to_ABC_Folders()    
    Dim FSO As Object
    Dim FromPath As String
    Dim sbFolder As Object

    FromPath = "R:\test" 

    Set FSO = CreateObject("scripting.filesystemobject")

    For Each sbFolder In FSO.getfolder(FromPath).subFolders
        If sbFolder.Name Like "A*" Then
            sbFolder.Move "R:\test\A"        
        End If
    Next sbFolder
    

End Sub

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook
    Pathname = "F:\! PROJECT\"
    Filename = Dir(Pathname & "*.xlsx")
    
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop

End Sub

Sub DoWork()
    'Workbook("Renamer").
    Dim xHyperlink As Hyperlink
        For Each xHyperlink In Worksheets("Combine Sheet").Hyperlinks
            For i = 2 To 280
                xHyperlink.Address = Replace(xHyperlink.Address, Worksheets("old_new").Cells(i, 1) & "\", Worksheets("old_new").Cells(i, 2) & "\")
            Next
        Next
End Sub

Sub FileList()
    Dim V As String
    Dim BrowseFolder As String
     
    'открываем диалоговое окно выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку или диск"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "Вы ничего не выбрали!"
            Exit Sub
        End If
    End With
    BrowseFolder = CStr(V)
     
    'добавляем лист и выводим на него шапку таблицы
    ActiveWorkbook.Sheets.Add
    With Range("A1:E1")
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A1").Value = "Имя файла"
    Range("B1").Value = "Путь"
    Range("C1").Value = "Размер"
    Range("D1").Value = "Дата создания"
    Range("E1").Value = "Дата изменения"
     
    'вызываем процедуру вывода списка файлов
    'измените True на False, если не нужно выводить файлы из вложенных папок
    ListFilesInFolder BrowseFolder, True
End Sub
 
 
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.getfolder(SourceFolderName)
 
    r = Range("A65536").End(xlUp).Row + 1   'находим первую пустую строку
    'выводим данные по файлу
    For Each FileItem In SourceFolder.Files
        Cells(r, 1).Formula = FileItem.Name
        Cells(r, 2).Formula = FileItem.Path
        Cells(r, 3).Formula = FileItem.Size
        Cells(r, 4).Formula = FileItem.DateCreated
        Cells(r, 5).Formula = FileItem.DateLastModified
        r = r + 1
        X = SourceFolder.Path
    Next FileItem
     
    'вызываем процедуру повторно для каждой вложенной папки
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
 
    Columns("A:E").AutoFit
 
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 3 Then
    Exit Sub
    Else
    ActiveCell.Formula = "=HYPERLINK("""",""" & ActiveCell.Text & """)"
    End If
End Sub

Dim wsMstr  As Worksheet: Set wsMstr = ThisWorkbook.Sheets("MasterCSV")

Sub ImportCSVsWithReference()
'Author:    Jerry Beaucaire
'Date:      10/16/2010
'Summary:   Import all CSV files from a folder into a single sheet
'           adding a field in column A listing the CSV filenames

Dim wbCSV   As Workbook
Dim wsMstr  As Worksheet:   Set wsMstr = ThisWorkbook.Sheets("MasterCSV")
Dim fPath   As String:      fPath = "C:\2010\Import\"    'path to CSV files, include the final \
Dim fCSV    As String

If MsgBox("Clear the existing MasterCSV sheet before importing?", vbYesNo, "Clear?") _
    = vbYes Then wsMstr.UsedRange.Clear

Application.ScreenUpdating = False  'speed up macro

fCSV = Dir(fPath & "*.csv")         'start the CSV file listing

    Do While Len(fCSV) > 0
      'open a CSV file
        Set wbCSV = Workbooks.Open(fPath & fCSV)
      'insert col A and add CSV name
        Columns(1).Insert xlShiftToRight
        Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
      'copy date into master sheet and close source file
        ActiveSheet.UsedRange.Copy wsMstr.Range("A" & Rows.Count).End(xlUp).Offset(1)
        wbCSV.Close False
      'ready next CSV
        fCSV = Dir
    Loop
 
Application.ScreenUpdating = True
End Sub

Private Sub hyperlink()
    Dim fd As Office.FileDialog
    Dim s As String
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
  With fd
      .AllowMultiSelect = False
      .InitialFileName = "D:\Docs"
      .Title = "Please select the file."
      .Filters.Clear
      .Filters.Add "PDF", "*.pdf"
      If .Show = True Then
        txtFileName = .SelectedItems(1)
      End If
   End With
   
   ActiveCell.Formula = "=HYPERLINK(txtFileName,ActiveCell.text)"
    
End Sub

' ZVI:2009-10-17 http://www.planetaexcel.ru/forum.php?thread_id=10602
' Функция возвращает одномерный массив уникальных отсортированных значений диапазона Rng
Function NoDups(rng As Range)
  Dim arr(), i&, s$, x
  ' Считать данные в массив, для удобства ограничиться последней строкой данных листа
 arr = Intersect(rng.Parent.UsedRange, rng).Value
  ' Создать список
  On Error Resume Next
  With New Collection
    For Each x In arr()
      s = Trim(x)
      If Len(s) > 0 Then
        If IsEmpty(.Item(s)) Then
          For i = 1 To .Count
            If s < .Item(i) Then Exit For
          Next
          If i > .Count Then .Add s, s Else .Add s, s, Before:=i
        End If
      End If
    Next
    ' Скопировать из коллекции в массив
    ReDim arr(1 To .Count)
    For i = 1 To .Count
      arr(i) = .Item(i)
    Next
  End With
  ' Вернуть массив
 NoDups = arr()
End Function

Sub Unique_Sorted()

Application.ScreenUpdating = False
' удаляем из колонки В старые значения
    Range("B1:B1000").Delete
' выбираем из колонки А уникальные и вставляем в колонку В начиная с ячейки В2
    ActiveSheet.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=ActiveSheet.Range("B2"), _
            Unique:=True
' сортируем отобранные значения по алфавиту
    ActiveSheet.Range("B2:B1000").Sort Key1:=ActiveSheet.Range("B2:B1000"), _
               Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
               MatchCase:=False, Orientation:=xlTopToBottom
' удаляем заголовок, если он дублирует первое значение уникального списка
    If Range("B2") = Range("B3") Then
    Range("B2").Delete Shift:=xlUp
    End If

Application.ScreenUpdating = True
End Sub