Excel-Makro läuft vom usb hält

Question

Looping Ich habe eine Excel-Datei, die einen Makro hat, die eine andere Blätter öffnet und einige Zellen Daten Schrott, es, indem Sie durch einen Ordner geschieht dann durch Unterordner suchen das ist das ganze Makro

Public strFileFullName As String 
Public currentIndex As Integer 
Public strFileFileName As String 


'Callback for customButton onAction 
Sub ScrapData(control As IRibbonControl) 

strFileFullName = ActiveWorkbook.FullName 
strFileFileName = ActiveWorkbook.Name 

'clear results sheet 
Sheets("Results").Activate 
Size = WorksheetFunction.CountA(Worksheets("Results").Columns(12)) 
Dim defRange As String 
defRange = "A" & 2 & ":L" & CStr(Size + 1) 
Worksheets("Results").Range(defRange).Clear 
currentIndex = 2 

'browse for file 
    With Application.FileDialog(msoFileDialogFolderPicker) 
     .AllowMultiSelect = False 
     If .Show = -1 Then 

      FolderName = .SelectedItems(1) 
     End If 
    End With 

    If (FolderName <> "") Then 
    Dim FileSystem As Object 
    Set FileSystem = CreateObject("Scripting.FileSystemObject") 
    DoFolder FileSystem.GetFolder(FolderName) 
    End If 
End Sub 

Sub CheckFile(file As String) 
     If (InStr(file, ".xlsm") > 0) And (file <> strFileFullName) Then 
     Call copyCell(file) 
     Exit Sub 
     End If 
End Sub 

Sub copyCell(FileName As String) 

On Error GoTo ErrorHandler1 

Application.DisplayAlerts = False 
Application.ScreenUpdating = False 

Workbooks.Open FileName:=FileName 
If (SheetExists("Home", ActiveWorkbook) And SheetExists("Front Section", ActiveWorkbook)) Then 
    'start copying from Home Sheet 
    Sheets("Home").Activate 
    AccessorName = Cells(26, "H").Value 
    LearnerName = Cells(21, "H").Value 
    Framework = Cells(6, "F").Value 

    'Start copying from front section sheet 
    Sheets("Front Section").Activate 
    StartDate = Cells(5, "G").Value 
    EndDate = Cells(6, "G").Value 
    Overall = Cells(7, "G").Text 
    DaysLeft = Cells(8, "P").Value 
    Status = Cells(9, "P").Value 
    NVQ = Cells(4, "P").Text 
    TC = Cells(5, "P").Text 
    ErrCel = Cells(6, "P").Text 
    FS = Cells(7, "P").Text 

    Else 
    GoTo ErrorHandler1 
    End If 

    'close opened sheet 
    ActiveWorkbook.Close 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 

    'start pasting into out sheet 
    Sheets("Results").Activate 
    Size = WorksheetFunction.CountA(Worksheets("Results").Columns(12)) 
    currentIndex = Size + 1 
    Cells(currentIndex, 1).Value = AccessorName 
    Cells(currentIndex, 2).Value = LearnerName 
    Cells(currentIndex, 3).Value = Framework 

    Cells(currentIndex, 4).Value = StartDate 
    Cells(currentIndex, 5).Value = EndDate 
    Cells(currentIndex, 6).Value = Overall 
    Cells(currentIndex, 7).Value = DaysLeft 
    Cells(currentIndex, 8).Value = Status 
    Cells(currentIndex, 9).Value = NVQ 
    Cells(currentIndex, 10).Value = TC 
    Cells(currentIndex, 11).Value = ErrCel 
    Cells(currentIndex, 12).Value = FS 
    Exit Sub 

ErrorHandler1: 
If ((ActiveWorkbook.FullName <> strFileFullName) Or (ActiveWorkbook.Name) <> strFileFileName) Then 
    ActiveWorkbook.Close 
    End If 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Exit Sub 

Exit Sub 

End Sub 



Sub DoFolder(Folder) 
    Dim SubFolder 
    For Each SubFolder In Folder.SubFolders 
     DoFolder SubFolder 

    Next 

    Dim file 
    For Each file In Folder.Files 
     CheckFile (file) 
    Next 
End Sub 

Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean 
    Dim sht As Worksheet 

    If wb Is Nothing Then Set wb = ThisWorkbook 
    On Error Resume Next 
    Set sht = wb.Sheets(shtName) 
    On Error GoTo 0 
    SheetExists = Not sht Is Nothing 
End Function 

dieses Makro funktioniert gut, wenn die Schaber Datei und geschabt Dateien auf dem Desktop sind oder wenn die Molch-Datei auf uSB und geschabt Dateien sind auf dem Desktop

das Problem löst, wenn sie alle auf usb existieren Schleifen es mehrere Zeit auf der gleichen Datei und wiederholt den Aufruf CheckFile Funktion Ich denke, es ist ein Einfädeln Problem ist, aber ich kann es nicht lösen .. wenn Sie mir helfen können, würde es groß sein

bearbeiten

ich, dass die Ausgabe zu sagen vergessen (die Gesamtzeilen) jeder Lauf unterscheidet sich von dem vorherigen (die Ausgabe sollte gleich sein, solange die abgekratzten Dateien gleich sind)

Answer 1

Basierend auf den Kommentaren scheint es, dass die USB-Schnittstelle die FSO-Aufzählung von Dateien stört wenn auf die Dateien zugegriffen wird, während das Verzeichnis durchlaufen wird. Eine Lösung wäre, um die Dateipfade in einem Durchgang zwischenspeichern, dann führen Operationen an sie in einem zweiten Durchlauf:

Private found As Collection 'Module scope. 

Sub ScrapData(control As IRibbonControl) 

    strFileFullName = ActiveWorkbook.FullName 
    strFileFileName = ActiveWorkbook.Name 

    'clear results sheet 
    Sheets("Results").Activate 
    Size = WorksheetFunction.CountA(Worksheets("Results").Columns(12)) 
    Dim defRange As String 
    defRange = "A" & 2 & ":L" & CStr(Size + 1) 
    Worksheets("Results").Range(defRange).Clear 
    currentIndex = 2 

    'browse for file 
    With Application.FileDialog(msoFileDialogFolderPicker) 
     .AllowMultiSelect = False 
     If .Show = -1 Then 
      FolderName = .SelectedItems(1) 
     End If 
    End With 

    If (FolderName <> "") Then 
     Dim FileSystem As Object 
     Set FileSystem = CreateObject("Scripting.FileSystemObject") 
     Set found = New Collection 
     'Data gathering pass... 
     DoFolder FileSystem.GetFolder(FolderName) 

     Dim path As Variant 
     'Processing pass gathering pass... 
     For Each path In found 
      CheckFile path 
     Next path 
    End If 
End Sub 

Sub DoFolder(Folder) 
    Dim SubFolder 
    For Each SubFolder In Folder.SubFolders 
     DoFolder SubFolder 
    Next 
    Dim file 
    For Each file In Folder.Files 
     found.Add file 
    Next 
End Sub 

EDIT: Je mehr ich darüber nachdenke, ich bin überrascht, dass es funktioniert auf einem nicht -USB Laufwerk - Wenn Sie ein Excel-Dokument öffnen, erstellt es eine versteckte Sperrdatei im Verzeichnis (~ $ filename.xlsm), die den Directory-Cache des FSO ungültig machen sollte.