エクセルマクロの実行は

Question

をループし続けるI別のシートを開き、いくつかのセルのデータをスクラップするマクロを持つExcelファイルは、それが、これはマクロ全体でサブフォルダ を通して見ているフォルダをブラウズすることで起こりました

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 

このマクロは、スクレーパーファイルとは、ファイルがデスクトップ上にあるか、スクレーパーファイルは、USB上で、掻き取った場合、ファイルがデスクトップ上にある、彼らはすべてのUSB 上に存在するときに問題が提起

は、それが複数のタイムループ掻き取った場合に正常に動作します同じファイルにあり、CheckFile関数01を呼び出す（私は出力と言うのを忘れて、あなたが私を助けることができるならば、それは素晴らしい

編集

だろう ..私はそれがスレッドの問題だと思うが、私はそれを解決することはできません合計行数）は前回のものとは異なります（出力されるファイルは同じです）

Answer 1

コメントに基づいて、USBインターフェイスがファイルの列挙を妨害しているようですファイルがディレクトリトラバーサルを完了している間にアクセスされている場合。一つの解決策は、次に、第2のパスでそれらの操作を実行、1回のパスでファイルパスをキャッシュするために、次のようになります。

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 

編集：より多くの私はこれについて考え、私はそれが以外に動作することを驚いています-USBドライブ - Excelドキュメントを開くと、FSOのディレクトリキャッシュを無効にする必要のある隠しロックファイル（〜$ filename.xlsm）が作成されます。