Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню Заметки | Перемещение офисных документов в зависимости от авторства


Rambler's Top100


Counter CO.KZ

Предположим, что у Вас в одной папке находятся офисные файлы, как правило, это .xls и .doc , созданные разными людьми и Вам необходимо, в зависимости от авторства, переместить эти файлы в соответствующие папки, т.е. все файлы, автором которых числится, к примеру, Иванов переместить в папку Иванов, и т.д. (см. скриншоты), то для этого можно воспользоваться нижеприведённым макросом.

До



После

Только не забудьте правильно указать папку - с обязательным завершающим слэшем \ , а также перечислить всех пользователей-авторов, причём так, как это указано в свойствах файла, т.е. если в фирме приветствуется панибратство и автором является, допустим, Андрей, то не нужно приписывать ему отчество, если же, напротив, всё слишком официозно, например, Орлова Наталья Сергеевна или Беляев И.И. , то не нужно оставлять только фамилию.
Private Sub FilesMoveToAuthorFolder()
    Dim iFolder As Object, iFolderItem As Object    
    Dim iFileName$, iNewFileName$, iPropertie$ ' 
    Dim iCount%, iPath, iAuthor, iArrList 'As Variant

    iPath = "C:\Мои документы\": iCount = Len(iPath) - 1
    
    Set iFolder = CreateObject("Shell.Application").NameSpace(iPath)
    If Not iFolder Is Nothing Then
    
       iArrList = Array("Климов П.Ю.", "Беляев И.И.", "Орлова Н.С.")
       For Each iAuthor In iArrList
           If Dir(iPath & iAuthor, vbDirectory) = "" _
           Then MkDir Path:=iPath & iAuthor
       Next

       'iPropertie = "Author"    'Win98/Me/2000
       iPropertie = "DocAuthor" 'WinXP
    
       For Each iFolderItem In iFolder.Items
           If iFolderItem.IsFileSystem = True Then
              iAuthor = iFolderItem.ExtendedProperty(iPropertie)
              If Not IsError(Application.Match(iAuthor, iArrList, 0)) Then
                 iFileName = iFolderItem.Path
                 iNewFileName = Application.Replace( _
                 iFileName, 1, iCount, iPath & iAuthor)
                 Name iFileName As iNewFileName
              End If
           End If
       Next
    Else
       MsgBox "Необходимо правильно указать папку", ,""
    End If    
End Sub
Комментарий : Данный макрос игнорирует скрытые файлы, кроме того, он перемещает любой офисный файл, вне зависимости от типа и если подобный расклад Вас не устраивает, то в Windows XP (Shell.dll version 6.0) появилась возможность фильтрации, которая и демонстрируется в следующем примере :
Private Sub FilesMoveToAuthorFolder2() 'Windows XP
    Dim iFolder As Object, iFolderItems As Object, iOfficeFile As Object
    Dim iFileName$, iNewFileName$, iPropertie$, iCount%
    Dim iPath, iAuthor, iArrList 'As Variant

    iPath = "C:\Мои документы\": iCount = Len(iPath) + 1
    
    Set iFolder = CreateObject("Shell.Application").NameSpace(iPath)
    If Not iFolder Is Nothing Then
       
       iArrList = Array("Климов П.Ю.", "Беляев И.И.", "Орлова Н.С.")
       For Each iAuthor In iArrList
           If Dir(iPath & iAuthor, vbDirectory) = "" _
           Then MkDir Path:=iPath & iAuthor
       Next
       
       Set iFolderItems = iFolder.Items
       iFolderItems.Filter 64 + 128, "*.xls"
       
       '64 - не перебирать папки
       '128 - учитывать скрытые файлы
       '"*.xls" - оставить только файлы с расширением .xls
       '"*.doc" - оставить только файлы с расширением .doc
       '"*.xls;*.doc" - оставить только файлы с расширением .xls и .doc
               
       'iPropertie = "Author"    'Win98/Me/2000
       iPropertie = "DocAuthor" 'WinXP

       For Each iOfficeFile In iFolderItems
           iAuthor = iOfficeFile.ExtendedProperty(iPropertie)
           If Not IsError(Application.Match(iAuthor, iArrList, 0)) Then
              iFileName = iOfficeFile.Path
              iNewFileName = Application.Replace( _
              iFileName, iCount, 0, iAuthor & "\")
              Name iFileName As iNewFileName
           End If
       Next
    Else
       MsgBox "Необходимо правильно указать папку", , ""
    End If
End Sub
Примечание : Если в папке, куда нам необходимо переместить офисный файл, окажется файл с таким же именем, в таком случае возникнет ошибка, которую можно избежать, если выбрать любой из трёх нижеприведённых вариантов :

1) Удалить старый файл, если он не представляет больше интереса, проще говоря, не нужен.
2) Если старый файл всё таки необходим, то добавить к имени нового файла некий постфикс, т.е. изменить имя "Отчёт_январь.xls" , к примеру, на "Отчёт_январь(2).xls"
3) Или возложить обязанности по перемещению файла на Shell, т.е. просто использовать метод MoveHere об'екта Folder. Это, кстати, позволит ещё и избежать проверки на наличие файла и генерации нового имени, т.к. в случае наличия файла "Отчёт_январь.xls" в папке автоматически появится "Копия Отчёт_январь.xls"
Private Sub FilesMoveToAuthorFolder3()
    iPath = "C:\Мои документы\"

    If Dir(iPath, vbDirectory) = "" Then
       MsgBox "Необходимо правильно указать папку", , ""
       Exit Sub
    End If

    iArrList = Array("Андрей", "Татьяна", "Сергей")
    For Each iAuthor In iArrList
        If Dir(iPath & iAuthor, vbDirectory) = "" _
        Then MkDir Path:=iPath & iAuthor
    Next

    Dim iFolder As Object, iFolderItem As Object
    Set iFolder = CreateObject("Shell.Application").NameSpace(iPath)
    For Each iFolderItem In iFolder.Items
        Application.StatusBar = iFolderItem.Path       
        If iFolderItem.IsFileSystem = True Then '
           iAuthor = iFolderItem.ExtendedProperty("DocAuthor")
           If Not IsError(Application.Match(iAuthor, iArrList, 0)) Then
              iFolder.ParseName( _
              iAuthor).GetFolder.MoveHere iFolderItem.Path, 8 + 16
           End If
        End If
    Next
    Application.StatusBar = False
End Sub
В принципе тоже самое, но добавлена фильтрация, аналогичная той, что была использована во втором примере.
Private Sub FilesMoveToAuthorFolder4() 'Windows XP
    iPath = "C:\Мои документы\"
    
    If Dir(iPath, vbDirectory) = "" Then
       MsgBox "Необходимо правильно указать папку", , ""
       Exit Sub
    End If
    
    Dim iShell As Object, iFolderItems As Object, iOfficeFile As Object
    Set iShell = CreateObject("Shell.Application")
    Set iFolderItems = iShell.NameSpace(iPath).Items

    iFolderItems.Filter 64 + 128 ', "*.xls;*.doc"
      
    '64 - не перебирать папки
    '128 - учитывать скрытые файлы
    '"*.xls" - оставить только файлы с расширением .xls

    iArrList = Array("Алексеев", "Никольский", "Шустриков")
    'Фамилии перечислены в отсортированном виде (по возрастанию)

    For Each iAuthor In iArrList
        If Dir(iPath & iAuthor, vbDirectory) = "" _
        Then iFolder.NewFolder iAuthor 'MkDir iPath & iAuthor
    Next
    
    For Each iOfficeFile In iFolderItems
        iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
        If IsNumeric(Application.Match(iAuthor, iArrList)) Then
           iShell.NameSpace(iPath & _
           iAuthor).MoveHere iOfficeFile.Path, 8 + 16
        End If
    Next
End Sub
Совет : Если файлов, которые требуется рассортировать по папкам, довольно много, то имеет смысл использовать либо статус-бар (см. третий пример), либо прогресс-бар, благо количество элементов в папке известно = iFolder.Items.Count или iFolderItems.Count


Если же самостоятельно составить список пользователей-авторов не представляется возможным, то эту задачу также можно решить с помощью VBA, например :
Private Sub FilesMoveToAllAuthorFolder() 'Windows XP

    Dim iFolder As Object, iFolderItems As Object
    Dim iOfficeFile As Object, iArchive As Object
    Dim iPath, iAuthor, iFileName ' As Variant

    iPath = "C:\Мои документы\"
    
    Set iFolder = _
    CreateObject("Shell.Application").NameSpace(iPath)
    
    If Not iFolder Is Nothing Then
       Set iFolderItems = iFolder.Items
       iFolderItems.Filter 64 + 128, "*.xls;*.doc"
    
       If iFolderItems.Count > 0 Then
          Set iArchive = CreateObject("Scripting.Dictionary")
          iArchive.CompareMode = 1 'TextCompare
    
          For Each iOfficeFile In iFolderItems
              iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
        
              If IsEmpty(iAuthor) = True _
              Then iAuthor = "Автор_неизвестен"
        
              If Not iArchive.Exists(iAuthor) Then _
              iArchive.Add iAuthor, New Collection
        
              iArchive(iAuthor).Add iOfficeFile.Path
          Next
   
          For Each iAuthor In iArchive.Keys
              If Dir(iPath & iAuthor, vbDirectory) = "" _
              Then MkDir Path:=iPath & iAuthor
        
              For Each iFileName In iArchive(iAuthor)
                  iFolder.ParseName( _
                  iAuthor).GetFolder.MoveHere iFileName, 8 + 16
              Next
          Next
       Else
          MsgBox "Рабочие книги в папке отсутствуют", , ""
       End If
    Else
       MsgBox "Необходимо правильно указать папку", , ""
    End If
    
End Sub
Private Sub FilesMoveToAllAuthorFolder2() 'Windows XP

    Dim iFolder As Object, iFolderItems As Object
    Dim iOfficeFile As Object, iAuthorFolder As Object
    Dim iArchive As Object, iPath, iAuthor, iFileName 'As Variant

    iPath = "C:\Мои документы\"
    
    If Dir(iPath, vbDirectory) = "" Then
       MsgBox "Необходимо правильно указать папку", , ""
       Exit Sub
    End If
    
    Set iFolder = _
    CreateObject("Shell.Application").NameSpace(iPath)
    
    Set iFolderItems = iFolder.Items    
    iFolderItems.Filter 64 + 128, "*.xls;*.doc"
    
    If iFolderItems.Count = 0 Then
       MsgBox "Рабочие книги в папке отсутствуют", , ""
       Exit Sub
    End If
    
    Set iArchive = CreateObject("Scripting.Dictionary")
    iArchive.CompareMode = 1 'TextCompare
    
    For Each iOfficeFile In iFolderItems
        iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
        
        If IsEmpty(iAuthor) = True _
        Then iAuthor = "Автор_неизвестен"
        
        If Not iArchive.Exists(iAuthor) Then _
        iArchive.Add iAuthor, New Collection
        
        iArchive(iAuthor).Add iOfficeFile.Path
    Next
   
    For Each iAuthor In iArchive.Keys
        If Dir(iPath & iAuthor, vbDirectory) = "" Then _
        iFolder.NewFolder iAuthor 'MkDir iPath & iAuthor
        
        Set iAuthorFolder = iFolder.ParseName(iAuthor).GetFolder
        
        For Each iFileName In iArchive(iAuthor)
            iAuthorFolder.MoveHere iFileName, 8 + 16
        Next
    Next
    
End Sub
Если же Вы принципиально не хотите использовать переменные, типа Variant или просто предпочитаете раннее связывание, то в таком случае обязательно добавьте ссылки на необходимые библиотеки (см. далее) и воспользуйтесь нижеопубликованным макросом :



Private Sub FilesMoveToAllAuthorFolder2v2() 'Windows XP

    'Следующие библиотеки обязательно должны быть подключены :
    'Microsoft Scripting RunTime
    'Microsoft Shell Controls And Automation

    Dim iShell   As New Shell32.Shell
    Dim iOfficeFile  As Shell32.FolderItem
    Dim iFolderItems As Shell32.FolderItems3
    Dim iArchive As New Scripting.Dictionary
    Dim iCountAuthor&, iCountFile&
    Dim iAuthor$, iFileName$, iPath$

    iPath = "C:\Мои документы\"
    
    If Len(Dir(iPath, vbDirectory)) = 0 Then
       MsgBox "Необходимо правильно указать папку", , ""
       Exit Sub
    End If

    Set iFolderItems = iShell.NameSpace(iPath).Items
    
    iFolderItems.Filter 64 + 128, "*.xls;*.doc"
    
    If iFolderItems.Count = 0 Then
       MsgBox "Рабочие книги в папке отсутствуют", , ""
       Exit Sub
    End If
    
    iArchive.CompareMode = 1 'TextCompare
    
    For Each iOfficeFile In iFolderItems
        iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
        
        If Len(iAuthor) = 0 Then iAuthor = "Автор_неизвестен"
        
        If Not iArchive.Exists(iAuthor) Then _
        iArchive.Add iAuthor, New Collection
        
        iArchive(iAuthor).Add iOfficeFile.Path
    Next
    
    For iCountAuthor = 0 To iArchive.Count - 1
        iAuthor = iArchive.Keys(iCountAuthor)      
        If Len(Dir(iPath & iAuthor,vbDirectory)) = 0 _
        Then MkDir iPath & iAuthor

        For iCountFile = 1 To iArchive(iAuthor).Count
            iFileName = iArchive(iAuthor)(iCountFile)          
            iShell.NameSpace(iPath & iAuthor).MoveHere iFileName, 8 + 16
        Next
    Next
    
End Sub
Private Sub FilesMoveToAllAuthorFolder2v3() 'Windows XP

    'Следующие библиотеки обязательно должны быть подключены :
    'Microsoft Scripting RunTime
    'Microsoft Shell Controls And Automation

    Dim iShell   As New Shell32.Shell
    Dim iOfficeFile  As Shell32.FolderItem
    Dim iFolderItems As Shell32.FolderItems3
    Dim iArchive As New Scripting.Dictionary
    Dim iCollection As Collection
    Dim iCountAuthor&, iCountFile&
    Dim iAuthor$, iFileName$, iPath$

    iPath = "C:\Мои документы\"
    
    If Len(Dir(iPath, vbDirectory)) = 0 Then
       MsgBox "Необходимо правильно указать папку", , ""
       Exit Sub
    End If

    Set iFolderItems = iShell.NameSpace(iPath).Items
    
    iFolderItems.Filter 64 + 128, "*.xls;*.doc"
    
    If iFolderItems.Count = 0 Then
       MsgBox "Рабочие книги в папке отсутствуют", , ""
       Exit Sub
    End If
    
    iArchive.CompareMode = 1 'TextCompare
    
    For Each iOfficeFile In iFolderItems
        iAuthor = iOfficeFile.ExtendedProperty("DocAuthor")
        
        iAuthor = iPath & _
        IIf(Len(iAuthor) = 0, "Автор_неизвестен", iAuthor)
        
        If Not iArchive.Exists(iAuthor) Then _
        iArchive.Add iAuthor, New Collection
        
        iArchive(iAuthor).Add iOfficeFile.Path
    Next
    
    For iCountAuthor = 0 To iArchive.Count - 1
        iAuthor = iArchive.Keys(iCountAuthor)
        If Len(Dir(iAuthor, vbDirectory)) = 0 Then MkDir iAuthor
        
        Set iCollection = iArchive(iAuthor)
        
        For iCountFile = 1 To iCollection.Count
            iFileName = iCollection(iCountFile)
            iShell.NameSpace(iAuthor).MoveHere iFileName, 8 + 16
        Next
    Next
    
End Sub


Вопросы, связанные с этой темой
  • FAQ95 : Как "назначить" клавишам свой собственный макрос ?
  • FAQ592 : Как используя об'ект Shell получить доступ к некоторым свойствам закрытого офисного документа ?
  • Article : Microsoft Excel 97 : Свойства закрытых офисных документов

  • FAQ421 : Как отобразить диалоговое окно, позволяющее выбрать нужную папку (Microsoft Excel XP и старше) ?
  • FAQ422 : Как используя об'ект Shell отобразить диалоговое окно, позволяющее выбрать нужную папку ?




  • Автор : Климов Павел Юрьевич
    © 2004-2016 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff