Excel 从usb运行的宏不断循环

Question

我有一个 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 函数我认为这是一个线程问题，但我无法解决它.. 如果你能帮助我，那就太好了

Edit

我忘了说每个运行的输出（总行数）与前一个不同（只要抓取的文件相同，输出应该相同）

Answer 1

根据评论，如果在完成目录遍历时访问文件，USB 接口似乎会干扰 FSO 的文件枚举。一种解决方案是一次性缓存文件路径，然后在第二次缓存中对它们执行操作：

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 文档时目录 (~$filename.xlsm) 中的隐藏锁文件应该会使 FSO 的目录缓存失效。

Excel 从usb运行的宏不断循环

Excel macro runs from usb keeps looping

usb

macros

excel

vba