Repetir arquivos em uma pasta usando o VBA?

236

Gostaria de percorrer os arquivos de um diretório usando no Excel 2010.

No loop, precisarei de:

  • o nome do arquivo e
  • a data em que o arquivo foi formatado.

Eu codifiquei o seguinte, que funciona bem se a pasta não tiver mais de 50 arquivos, caso contrário, é ridiculamente lenta (eu preciso que ela trabalhe com pastas com> 10000 arquivos). O único problema desse código é que a operação para procurar file.nameleva muito tempo.

Código que funciona, mas é muito lento (15 segundos por 100 arquivos):

Sub LoopThroughFiles()
   Dim MyObj As Object, MySource As Object, file As Variant
   Set MySource = MyObj.GetFolder("c:\testfolder\")
   For Each file In MySource.Files
      If InStr(file.name, "test") > 0 Then
         MsgBox "found"
         Exit Sub
      End If
   Next file
End Sub

Problema resolvido:

  1. Meu problema foi resolvido com a solução abaixo usando Dirde uma forma particular (20 segundos para 15000 arquivos) e para verificar o carimbo de tempo usando o comando FileDateTime.
  2. Levando em conta outra resposta abaixo dos 20 segundos, é reduzido para menos de 1 segundo.
tyrex
fonte
Sua hora inicial parece lenta para o VBA ainda. Você está usando Application.ScreenUpdating = false?
Michiel van der Blonk
2
Parece que você está perdendo codeSet MyObj = New FileSystemObject
baldmosher
13
Acho muito triste que as pessoas sejam rápidas em chamar o FSO de "lento", mas ninguém menciona a penalidade de desempenho que você poderia evitar usando simplesmente a ligação antecipada em vez de chamadas com ligação tardia Object.
Mathieu Guindon

Respostas:

46

Aqui está minha interpretação como uma função:

'#######################################################################
'# LoopThroughFiles
'# Function to Loop through files in current directory and return filenames
'# Usage: LoopThroughFiles ActiveWorkbook.Path, "txt" 'inputDirectoryToScanForFile
'# /programming/10380312/loop-through-files-in-a-folder-using-vba
'#######################################################################
Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As String

    Dim StrFile As String
    'Debug.Print "in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile

    StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
    Do While Len(StrFile) > 0
        Debug.Print StrFile
        StrFile = Dir

    Loop

End Function
benmichae2.
fonte
25
por que função, quando nada é retornado? Não é este mesmo como a resposta dada por brettdj, excepto que é colocado entre uma função
Shafeek
253

Dirutiliza curingas para que você possa fazer uma grande diferença adicionando o filtro testantecipadamente e evitando testar cada arquivo

Sub LoopThroughFiles()
    Dim StrFile As String
    StrFile = Dir("c:\testfolder\*test*")
    Do While Len(StrFile) > 0
        Debug.Print StrFile
        StrFile = Dir
    Loop
End Sub
brettdj
fonte
29
ÓTIMO. Isso apenas melhorou o tempo de execução de 20 segundos para <1 segundos. Essa é uma grande melhoria, pois o código será executado com bastante frequência. OBRIGADO!!
Tyrex # 30/12
Pode ser porque o loop Do while ... é melhor do que o while ... wend. mais informações aqui stackoverflow.com/questions/32728334/…
Hila DG
6
Não acho que por esse nível de melhoria (20 - xxx vezes) - acho que é o curinga que faz a diferença.
28416 brettdj
DIR () não parece retornar arquivos ocultos.
Hamish
@hamish, você pode alterar seu argumento para retornar diferentes tipos de arquivos (oculto, sistema etc.) - consulte a documentação do MS: docs.microsoft.com/en-us/office/vba/language/reference/…
Vincent
158

Dir parece ser muito rápido.

Sub LoopThroughFiles()
    Dim MyObj As Object, MySource As Object, file As Variant
   file = Dir("c:\testfolder\")
   While (file <> "")
      If InStr(file, "test") > 0 Then
         MsgBox "found " & file
         Exit Sub
      End If
     file = Dir
  Wend
End Sub
grantnz
fonte
3
Ótimo, muito obrigado. Eu uso Dir, mas não sabia que você também pode usá-lo dessa maneira. Além do comando, FileDateTimemeu problema está resolvido.
tyrex
4
Ainda uma pergunta. Eu poderia melhorar seriamente a velocidade se o DIR fizesse um loop começando com os arquivos mais recentes. Você vê alguma maneira de fazer isso?
tyrex
3
Minha última pergunta foi resolvida pelo comentário abaixo de brettdj.
tyrex
Dir vai notno entanto traverse the whole directory tree. Caso seja necessário: analystcave.com/vba-dir-function-how-to-traverse-directories/…
AnalystCave.com
Dir também será interrompido por outros comandos Dir; portanto, se você executar uma sub-rotina contendo Dir, ela poderá "redefinir" em sua sub original. O uso do FSO conforme a pergunta original elimina esse problema. EDIT: acabou de ver a mensagem por @LimaNightHawk abaixo, a mesma coisa
baldmosher
26

A função Dir é o caminho a seguir, mas o problema é que você não pode usar a Dirfunção recursivamente , conforme indicado aqui, na parte inferior .

A maneira como lidei com isso é usar a Dirfunção para obter todas as subpastas da pasta de destino e carregá-las em uma matriz, depois passar a matriz para uma função que se repita.

Aqui está uma aula que escrevi que realiza isso, que inclui a capacidade de procurar filtros. ( Você terá que perdoar a notação húngara, isso foi escrito quando havia toda a raiva. )

Private m_asFilters() As String
Private m_asFiles As Variant
Private m_lNext As Long
Private m_lMax As Long

Public Function GetFileList(ByVal ParentDir As String, Optional ByVal sSearch As String, Optional ByVal Deep As Boolean = True) As Variant
    m_lNext = 0
    m_lMax = 0

    ReDim m_asFiles(0)
    If Len(sSearch) Then
        m_asFilters() = Split(sSearch, "|")
    Else
        ReDim m_asFilters(0)
    End If

    If Deep Then
        Call RecursiveAddFiles(ParentDir)
    Else
        Call AddFiles(ParentDir)
    End If

    If m_lNext Then
        ReDim Preserve m_asFiles(m_lNext - 1)
        GetFileList = m_asFiles
    End If

End Function

Private Sub RecursiveAddFiles(ByVal ParentDir As String)
    Dim asDirs() As String
    Dim l As Long
    On Error GoTo ErrRecursiveAddFiles
    'Add the files in 'this' directory!


    Call AddFiles(ParentDir)

    ReDim asDirs(-1 To -1)
    asDirs = GetDirList(ParentDir)
    For l = 0 To UBound(asDirs)
        Call RecursiveAddFiles(asDirs(l))
    Next l
    On Error GoTo 0
Exit Sub
ErrRecursiveAddFiles:
End Sub
Private Function GetDirList(ByVal ParentDir As String) As String()
    Dim sDir As String
    Dim asRet() As String
    Dim l As Long
    Dim lMax As Long

    If Right(ParentDir, 1) <> "\" Then
        ParentDir = ParentDir & "\"
    End If
    sDir = Dir(ParentDir, vbDirectory Or vbHidden Or vbSystem)
    Do While Len(sDir)
        If GetAttr(ParentDir & sDir) And vbDirectory Then
            If Not (sDir = "." Or sDir = "..") Then
                If l >= lMax Then
                    lMax = lMax + 10
                    ReDim Preserve asRet(lMax)
                End If
                asRet(l) = ParentDir & sDir
                l = l + 1
            End If
        End If
        sDir = Dir
    Loop
    If l Then
        ReDim Preserve asRet(l - 1)
        GetDirList = asRet()
    End If
End Function
Private Sub AddFiles(ByVal ParentDir As String)
    Dim sFile As String
    Dim l As Long

    If Right(ParentDir, 1) <> "\" Then
        ParentDir = ParentDir & "\"
    End If

    For l = 0 To UBound(m_asFilters)
        sFile = Dir(ParentDir & "\" & m_asFilters(l), vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem)
        Do While Len(sFile)
            If Not (sFile = "." Or sFile = "..") Then
                If m_lNext >= m_lMax Then
                    m_lMax = m_lMax + 100
                    ReDim Preserve m_asFiles(m_lMax)
                End If
                m_asFiles(m_lNext) = ParentDir & sFile
                m_lNext = m_lNext + 1
            End If
            sFile = Dir
        Loop
    Next l
End Sub
LimaNightHawk
fonte
Se eu gostaria de listar os arquivos encontrados na coluna, o que poderia ser uma implementação disso?
28414 jechaviz
@jechaviz O método GetFileList retorna uma matriz de String. Você provavelmente iteraria sobre a matriz e adicionaria os itens a um ListView, ou algo assim. Detalhes sobre como mostrar itens em uma exibição de lista provavelmente estão além do escopo desta postagem.
LimaNightHawk
6

Dir A função perde o foco facilmente quando eu manuseio e processo arquivos de outras pastas.

Eu obtive melhores resultados com o componente FileSystemObject.

Exemplo completo é dado aqui:

http://www.xl-central.com/list-files-fso.html

Não se esqueça de definir uma referência no Editor do Visual Basic para Microsoft Scripting Runtime (usando Ferramentas> Referências)

De uma chance!

felipe gaviria correa
fonte
Tecnicamente, esse é o método que o solicitante está usando, eles simplesmente não têm suas referências incluídas, o que atrasaria esse método.
precisa
-2

Tente este. ( LINK )

Private Sub CommandButton3_Click()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    xWs.Copy
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56:
                FileExtStr = ".xls": FileFormatNum = 56
            Case Else:
                FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
    xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
    Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
    Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True

End Sub
Meelis Tara
fonte