Excel Vba Как избежать многократного повторения папки

Question

В настоящее время у меня есть код, который перебирает папку и файлы внутри папки, чтобы «получить данные» (не важно) в таблицу Excel

, но каждый раз, когда я запускаю код, он должен будет go через всю папку, и, скажем, если у меня есть 300 файлов, он будет go через все 300 файлов, чтобы "получить данные", даже если данные уже существуют в листе Excel, поэтому это занимает очень много времени.

Я хотел бы отсканировать столбец «E» (содержит имена файлов) на моем листе Excel с именем «Main», а затем добавить его в словарь, а затем после этой проверки на новое имя файла, например, EG, если первый запуск сохранен 60 имен файлов в словарь, если во втором прогоне есть новые файлы, добавьте его в словарь, затем «получите данные», если нет новых файлов, просто оставьте его.

Любая помощь будет высоко оценена. Огромное спасибо.

Мне удалось найти здесь этот код, который, кажется, должен использоваться, но я понятия не имею, как я могу настроить его под свои нужды,

Sub DictionaryGroupData(rngInput As Range, keyColIndex As Long, blHeaders As Boolean)
    'Must add reference to Tools > References > Microsoft Scripting Runtime
    Dim i As Long
    Dim rngCell As Range, rng As Range, rngTemp As Range
    Dim dict As Scripting.Dictionary
    Dim strVal As String
    Dim varOrigItems As Variant, varUniqueItems As Variant, varKey As Variant, _
        varItem As Variant

    Application.ScreenUpdating = False

    Set rng = rngInput.Columns(keyColIndex)
    Set dict = New Scripting.Dictionary

    ' set compare mode to text
    dict.CompareMode = TextCompare

    ' offset by one row if range has headers
    If blHeaders Then
        With rngInput
            Set rngInput = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
        End With
    End If

    ' add keys and values to dictionary
    With rngInput
        For Each rngCell In rngInput.Columns(keyColIndex).Cells
            i = i + 1
            strVal = rngCell.Text

            ' add new key and item range
            If Not dict.Exists(strVal) Then
                dict.Add strVal, .Rows(i)

            ' merge item ranges of existing key
            Else
                Set rngTemp = Union(.Rows(i), dict(strVal))
                dict.Remove strVal ' simply updating the item in a loop will cause a run-time error!
                dict.Add strVal, rngTemp
            End If
        Next rngCell
    End With

    For Each varKey In dict.Keys
        ' *********************************************
        'Insert your code here
        ' *********************************************
        Debug.Print varKey & ": " & dict.Item(varKey).Address ' remove in production
    Next varKey
    ' *********************************************
    ' or add code here for specific key actions
    ' dict("A").Select
    ' *********************************************
    Application.ScreenUpdating = True

End Sub

Answer 1

Вот пример кода, который показывает, как использовать словарь для вашей заявленной цели:

Sub tgr()

    'Define the column containing your Filenames here
    Const FileNamesColumn As String = "E"

    'Enter the folder path that contains the files you'll be looping through here
    Dim FolderPath As String
    FolderPath = "C:\Test\"

    'Set the worksheet to where your data is stored, this sample code assumes activesheet of activeworkbook
    Dim ws As Worksheet
    Set ws = ActiveWorkbook.ActiveSheet

    'Prepare the dictionary variable
    Dim FileNamesList As Object
    Set FileNamesList = CreateObject("Scripting.Dictionary")

    'Loop through the filenames in your filenames column, starting at row 2 to skip the header row (adjust as necessary)
    Dim FileName As Variant
    For Each FileName In ws.Range(ws.Cells(2, FileNamesColumn), ws.Cells(ws.Rows.Count, FileNamesColumn).End(xlUp)).Value
        If Not FileNamesList.Exists(FileName) Then FileNamesList(FileName) = FileName
    Next FileName

    'Ensure that the FolderPath ends in \
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"

    'Get initial file for iterating over what's stored in the directory
    'The *.xl?? restricts what you're itering over to only Excel files
    Dim CurrentFileName As String
    CurrentFileName = Dir(FolderPath & "*.xl??")

    'Create a variable to track how many new files were processed
    Dim ProcessedCount As Long
    ProcessedCount = 0

    'Disable calculation, events, and screenupdating to allow code to run faster and prevent "screen flickering"
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'Begin the loop
    Do While Len(CurrentFileName) > 0
        'Verify this is a new file and that it's name doesn't exist in the dictionary FileNamesList
        If Not FileNamesList.Exists(CurrentFileName) Then
            'New file found, provide status update to user and increase ProcessedCount
            Application.StatusBar = "Importing from new file: " & CurrentFileName   'Provide status update so user knows code is running
            ProcessedCount = ProcessedCount + 1

            'Open the file and process it
            With Workbooks.Open(FolderPath & CurrentFileName)
                '''''''''''''''''''''''''''''''''''''''''''''
                'Your code for processing this new file here'
                '''''''''''''''''''''''''''''''''''''''''''''
                'Example where you bring in the first value of the opened workbook and return it to the first open cell of column A of your "master" workbook that you're running the code from
                ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1).Value = .Worksheets(1).Range("A1").Value

                .Close False    'Close the opened file
            End With

            'Add this new filename to your list in filenames column so that the next time the code is run this file will be skipped (if this isn't already done with your code for processing the file)
            ws.Cells(ws.Rows.Count, FileNamesColumn).End(xlUp).Offset(1).Value = CurrentFileName
        End If
        CurrentFileName = Dir()    'Advance to next file
    Loop

    'Re-enable calculation, events, and screenupdating
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Application.StatusBar = vbNullString    'Clear the status bar so it resumes normal operation

    'Provide message informing the code has completed and how many new files were processed
    MsgBox ProcessedCount & " new files processed."

End Sub