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

修改

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

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的目录缓存无效。

从usb运行的Excel宏保持循环

1 个答案: