Чтение не дублируемых значений из текстового файла в коллекцию

Question

У меня возникли трудности с заполнением коллекции уникальными значениями из большого текстового файла, из которого я читаю. Я попытался прочесть все значения в коллекции, а затем удалить дубликаты, но код, который я использовал для этого, занимает много времени. Я продолжаю читать об идентификации объектов коллекции с помощью уникальных «ключей», но я не уверен, как включить это в код, который у меня есть, и в то, что я хотел бы выполнить. Ниже приведен текущий код у меня есть:

Option Explicit 
Private Sub UserForm_Initialize() 
    'Declare variables 
    Const CMMData As String = "\\ATSTORE01\CMMData\21064D\21064D-OP400.dat" 
    Dim strSN As New Collection 
    Dim strSet As New Collection 
    Dim strUniqueSet As New Collection 
    Dim strFF As New Collection 
    Dim strVHCC As New Collection 
    Dim strVHCCMID As New Collection 
    Dim strVHCVMID As New Collection 
    Dim strVHCV As New Collection 
    Dim strHWCC As New Collection 
    Dim strHWCCMID As New Collection 
    Dim strHWCVMID As New Collection 
    Dim strHWCV As New Collection 
    Dim LineData As String 
    Dim SplitData() As String 
    Dim LineIter As Long 
    Dim UniqueSet As Variant 
    Dim UniqueSet1 As Variant 
    'Populate Set Number Listbox 
    LineIter = 0 
    With New Scripting.FileSystemObject 
     With .OpenTextFile(CMMData, ForReading) 
      Do Until .AtEndOfStream 
       LineIter = LineIter + 1 
       If LineIter <= 4 Then 
        .SkipLine 
       Else 
        LineData = .ReadLine 
        SplitData = Split(LineData, ",") 
        'Extracting Serial Number 
        strSN.Add SplitData(0) 
        'Extracting Set Number 
        strSet.Add SplitData(1) 
        'Extracting Unique Set Number 
        strUniqueSet.Add SplitData(1) 'This is where I'd like to very cleanly extract only unique, non-duplicate set numbers into this particular collection. 
        'Extracting Final Flow Area 
        strFF.Add SplitData(14) 
        'Extracting /V/ To Hook CC 
        strVHCC.Add SplitData(96) 
        'Extracting /V/ To Hook CC Mid 
        strVHCCMID.Add SplitData(97) 
        'Extracting /V/ To Hook CV Mid 
        strVHCVMID.Add SplitData(98) 
        'Extracting /V/ To Hook CV 
        strVHCV.Add SplitData(99) 
        'Extracting Hook Width CC 
        strVHCV.Add SplitData(134) 
        'Extracting Hook Width CC Mid 
        strVHCV.Add SplitData(135) 
        'Extracting Hook Width CV Mid 
        strVHCV.Add SplitData(136) 
        'Extracting Hook Width CV 
        strVHCV.Add SplitData(137) 
        'Set_Select.AddItem SplitData(1) 
       End If 
      Loop 
      .Close 
     End With 
     'Below is the code I was using to remove the duplicate entries from the strUniqueSet collection 
     For UniqueSet = strUniqueSet.Count To 2 Step -1 
      For UniqueSet1 = (UniqueSet - 1) To 1 Step -1 
       On Error GoTo DisplayUniqueSet 
       If strUniqueSet.Item(UniqueSet) = strUniqueSet.Item(UniqueSet1) Then 
        strUniqueSet.Remove (UniqueSet) 
       Else 
        Set_Select.AddItem strUniqueSet(UniqueSet) 
       End If 
      Next UniqueSet1 
     Next UniqueSet 
    End With 
    Exit Sub 
DisplayUniqueSet: 
    MsgBox UniqueSet 
End Sub 

Конечная цель данного раздела кода для заполнения ListBox со значениями из коллекции strUniqueSet. Затем пользователь выбирает не дублируемое заданное число, и программа затем извлекает из других коллекций все значения, соответствующие этому выбранному номеру набора.

Я очень благодарен за помощь.

Answer 1

Коллекции и словари могут быть медленными, по моему опыту, особенно если вы несколько объектов одного и того же кода. Я бы предложил загрузить значения в многомерный массив и сначала зациклить массив, чтобы увидеть, существуют ли значения, и только добавление, если это не так. Затем вы можете захватывать информацию из массива, когда пользователь выбирает недвойный номер, снова зацикливая массив.

См. Код ниже. Обратите внимание, что он будет генерировать несколько элементов массива, которые по существу пустые в текущем способе написания.

Option Explicit 
Private Sub UserForm_Initialize() 

    Const CMMData As String = "\\ATSTORE01\CMMData\21064D\21064D-OP400.dat" 
    Dim LineData As String 
    Dim SplitData() As String 
    Dim LineIter As Long 
    Dim UniqueSet As Variant 
    Dim UniqueSet1 As Variant 

    Dim myArray() As String 
    ReDim myArray(10, 0) 


    LineIter = 0 
    With New Scripting.FileSystemObject 
     With .OpenTextFile(CMMData, ForReading) 
      Do Until .AtEndOfStream 

       LineIter = LineIter + 1 

       ReDim Preserve myArray(10, LineIter) 

       If LineIter <= 4 Then 
        myArray(1,LineIter) = "empty" & LineIter 
        .SkipLine 
       Else 

        LineData = .ReadLine 
        SplitData = Split(LineData, ",") 

        Dim x As Long, bFound As Boolean 

        bFound = False 
        For x = LBound(myArray) To UBound(myArray) 

         If myArray(1, x) = SplitData(1) Then 'look if Set already exists 
          bFound = True 
          Exit For 
         End If 

        Next 

        If Not bFound Then 'if its not in array already, then add it 

         myArray(0, LineIter) = SplitData(0) 
         myArray(1, LineIter) = SplitData(1) 
         myArray(2, LineIter) = SplitData(14) 
         myArray(3, LineIter) = SplitData(96) 
         myArray(4, LineIter) = SplitData(97) 
         myArray(5, LineIter) = SplitData(98) 
         myArray(6, LineIter) = SplitData(99) 
         myArray(7, LineIter) = SplitData(134) 
         myArray(8, LineIter) = SplitData(135) 
         myArray(9, LineIter) = SplitData(136) 
         myArray(10, LineIter) = SplitData(137) 

        Else 

         myArray(1, LineIter) = "empty" & LineIter 

        End If 

       End If 

      Loop 
      .Close 
     End With 

    End With 

End Sub 

Answer 2

Изучив ваш код, я не думаю, что коллекции или словари подходят. Я дал ответ, который, как я буду решать ваши требования. Я добавлю что-то на сборниках и словарях, если вы спросите, но я подозреваю, что этот ответ содержит достаточно, чтобы вы могли учиться на данный момент.

Сначала мне нужны были некоторые данные испытаний. Начиная с пустой таблицы, я заполнил строки от 1 до 10001 и столбцы с 1 по 155 с уникальными значениями. Я устанавливаю столбец B для повторений значений «A» на «Z». Я экспортировал эти данные в виде CSV-файла с именем «Import.csv».

Не изобретайте велосипед. Excel имеет совершенно адекватную процедуру для импорта CSV-файла, поэтому нет необходимости кодировать свою собственную процедуру в VBA. Я редко работаю с CSV-файлами, поэтому не помню синтаксис VBA операторов, необходимых для вызова процедуры импорта. Я включил макросъемку, импортировал CSV-файл (кроме первых 4 строк) и выключил макрорекордер. Я прибрал код макрорекордера, чтобы сформировать первую часть моей программы.

Макро-рекордер создает синтаксически правильный код, но не код хорошей практики. Он не знает ваших целей, поэтому записывает именно то, что вы делаете, когда делаете это. Я сомневаюсь, что у вас 155 столбцов, и вы можете указать для некоторых столбцов формат, отличный от «Общие». Вам придется переделать ручной импорт с вашими данными и убрать код так, как я.

Начало кода, записанного для меня было:

With ActiveSheet.QueryTables.Add(Connection:= _ 
    "TEXT;C:\Users\Admin\Desktop\Import.csv", Destination:=Range("A1")) 
    .Name = "Import" 

Я убирала это, чтобы получить:

With WshtIn 
.Cells.EntireRow.Delete   ' Delete existing content 
    With .QueryTables.Add(Connection:="TEXT;" & ActiveWorkbook.Path & _ 
            "\Import.csv", Destination:=.Range("A1")) 
    .Name = "DataIn" 

Лучше всего, чтобы избежать использования ActiveSheet. Я указал переменную типа Worksheet, WshtIn и установил ее на рабочий лист, который я хочу использовать.

Исходная строка связи TEXT;C:\Users\Admin\Desktop\Import.csv - это единственный литерал, который я заменил выражением.

У меня почти всегда есть мои книги и файлы, которые они обрабатывают в одной папке. ActiveWorkbook.Path дает мне папку с моей книгой. Используя это как имя моей папки, я могу переместить файлы в новую папку, и код все еще работает.

Destination:=Range("A1") полагается на пункт назначения, находящийся в пределах ActiveSheet. Добавление периода в начале для создания .Destination:=Range("A1") означает, что пункт назначения находится на рабочем листе, определяемом With WshtIn.

Наконец-то я заменил .Name = "Import" на .Name = "DataIn", потому что мне не нужен рабочий лист, названный в качестве файла CSV.

Оставшийся код я сохранил без изменений, за исключением дополнительного End With в конце. Как я уже сказал, вам придется заменить код импорта кодом, соответствующим вашим потребностям. Я предлагаю вам импортировать CSV-файл с включенным макрорекордером. Начните новый макрос на основе записанного кода и поиграйте с ним, пока не получите макрос, чтобы импортировать CSV так, как вы хотите, прежде чем смотреть на следующий бит моего кода.

Вы хотите только 11 столбцов этого CSV-файла. Поэтому я закодировал цикл, который перемещает эти 11 столбцов на новый рабочий лист «DataKeep». Макро-рекордер не выполняет петли, поэтому не будет никакой помощи; вы должны знать соответствующий синтаксис, чтобы закодировать это. Я использовал массив для определения столбцов для перемещения. Я считаю, что я правильно указал столбцы, но вам нужно будет проверить. Вероятно, лучше всего добавить этот код в свой макрос и получить его правильно, прежде чем двигаться дальше.

Рабочий лист «DataKeep» содержит только нужные данные. Я отбросил первые 4 строки, когда я их импортировал, и я оставил только интересующую колонку. Далее по порядку вы найдете:

Data = .Range(…).Value 

Это загружает содержимое диапазона в Data как двухмерный массив. Для большинства массивов соглашение состоит в том, чтобы иметь столбцы как первое измерение, а строки - как второе, так что ReDim Preserve может использоваться для увеличения количества строк. Однако для массивов, загружаемых с листа или подготовленных для загрузки на рабочий лист, первое измерение относится к строкам, а второе относится к столбцам. Это полезно, потому что оно соответствует синтаксису для ячейки: Cells(RowNumber, ColNumber).

В конце моего макроса я покажу, как получить доступ к данным, отобразив первые 20 строк. Это не список коллекций, которые у вас есть в коде, но я считаю, что вы найдете массив более удобным.

Самый простой способ получить список уникальных значений для столбца Set - использовать расширенный автофильтр. Опять же, это то, что я не использую очень часто, и у меня нет правильного синтаксиса на моих кончиках пальцев. Я использовал макрорекордер для захвата необходимого кода, когда создал список уникальных наборов. Я скопировал видимые ячейки в этом списке как массив до UniqueSets. Я считаю, что мой код будет соответствовать вашим требованиям без поправок, но вы можете попытаться создать этот код с помощью макрорекордера в качестве учебного упражнения.

Проработайте мой код, обновив его при необходимости и изучите, как я достиг эффекта, который у меня есть. В коде есть больше инструкций и объяснений. Вернитесь с вопросами по мере необходимости, но чем больше вы сами поймете, тем быстрее вы будете развиваться.

Option Explicit 

    ' Constants allow you to name columns rather than use numbers or letters that 
    ' may change. If the position of a column changes, amend the Const statement and 
    ' the code is fully updated. Searching code for the old column number so it can 
    ' be updated to the new can be a nightmare. 
    ' I have guessed names for the columns based on your code. Change as necessary. 
    ' ColKeepSet is the only one I use. 
    Const ColKeepSN As Long = 1 
    Const ColKeepSet As Long = 2 
    Const ColKeepFF As Long = 3 
    Const ColKeepVHCC As Long = 4 
    Const ColKeepVHCCMID As Long = 5 
    Const ColKeepVHCVMID As Long = 6 
    Const ColKeepVHCV1 As Long = 7 
    Const ColKeepVHCV2 As Long = 8 
    Const ColKeepVHCV3 As Long = 9 
    Const ColKeepVHCV4 As Long = 10 
    Const ColKeepVHCV5 As Long = 11 
Sub Import() 

    Dim ColInCrnt As Variant 
    Dim ColKeepCrnt As Long 
    Dim ColKeepLast As Long 
    Dim ColWidths() As Long 
    Dim Data As Variant 
    Dim Headings As Variant 
    Dim RngFilter As Range 
    Dim RngUnique As Range 
    Dim RowKeepCrnt As Long 
    Dim RowKeepLast As Long 
    Dim RowKeepSetLast As Long 
    Dim RowUnqCrnt As Long 
    Dim UniqueSets As Variant 
    Dim WshtIn As Worksheet 
    Dim WshtKeep As Worksheet 

    ' Change the names of the worksheets as necessary 
    Set WshtIn = Worksheets("DataIn") 
    Set WshtKeep = Worksheets("DataKeep") 

    ' Import the CSV file. Change "Import.csv" to your filename. Change folder if necessary. 
    With WshtIn 
    .Cells.EntireRow.Delete   ' Delete existing content 
    With .QueryTables.Add(Connection:="TEXT;" & ActiveWorkbook.Path & "\Import.csv", Destination:=.Range("A1")) 
     .Name = "DataIn" 
     .FieldNames = True 
     .RowNumbers = False 
     .FillAdjacentFormulas = False 
     .PreserveFormatting = True 
     .RefreshOnFileOpen = False 
     .RefreshStyle = xlInsertDeleteCells 
     .SavePassword = False 
     .SaveData = True 
     .AdjustColumnWidth = True 
     .RefreshPeriod = 0 
     .TextFilePromptOnRefresh = False 
     .TextFilePlatform = 850 
     .TextFileStartRow = 5 
     .TextFileParseType = xlDelimited 
     .TextFileTextQualifier = xlTextQualifierDoubleQuote 
     .TextFileConsecutiveDelimiter = False 
     .TextFileTabDelimiter = False 
     .TextFileSemicolonDelimiter = False 
     .TextFileCommaDelimiter = True 
     .TextFileSpaceDelimiter = False 
     .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _ 
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _ 
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _ 
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _ 
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _ 
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1) 
     .TextFileTrailingMinusNumbers = True 
     .Refresh BackgroundQuery:=False 
    End With 
    End With 

    ' Copy the required columns from worksheet "DataIn" to "DataKeep" 
    WshtKeep.Rows.Delete  ' Discard any reviosu data 
    ColKeepCrnt = 1 
    For Each ColInCrnt In Array(1, 2, 15, 97, 98, 99, 100, 135, 136, 137, 138) 
    WshtIn.Columns(ColInCrnt).Copy Destination:=WshtKeep.Cells(1, ColKeepCrnt) 
    ColKeepCrnt = ColKeepCrnt + 1 
    Next 

    ' Delete contents of Worksheet "DataIn" which are no longer needed 
    WshtIn.Rows.Delete 

    With WshtKeep 

    RowKeepSetLast = .Cells(Rows.Count, ColKeepSet).End(xlUp).Row 
    Set RngFilter = .Range(.Cells(1, ColKeepSet), _ 
          .Cells(RowKeepSetLast, ColKeepSet)) 

    .Columns(ColKeepSet).AutoFilter 
    RngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True 

    ' One copy of each unqiue set will be visible. In addition row 1 will be visible 
    ' because Excel assumes it is a header row. 

    Set RngUnique = .Range(.Cells(2, ColKeepSet), _ 
          .Cells(RowKeepSetLast, ColKeepSet)).SpecialCells(xlCellTypeVisible) 

    Debug.Print RngUnique.Address 
    UniqueSets = RngUnique.Value 

    .Columns(ColKeepSet).AutoFilter  ' Clear 

    ' There are various methods of finding the last used row and column. Above I have used 
    ' .End(xlUp) which is the easiest method of finding the last row of a column. Your data 
    ' is almost certainly rectangular so I could have assumed that the last row of the Set 
    ' column is the last row of all columns. Since I have saved selected columns, I could 
    ' have deduced the last column from that. However, I have decided to show a different 
    ' technique. 
    ' Both of the following statements use Find to locate the last cell contaning a value. 
    ' Both start the search "After" cell A1 and the search direction is "xlPrevious". 
    ' The previous cell from A1 is the bottom, right cell so both searches got up and across 
    ' until they find a cell with a value. In the first the search order is "xlByRows" and 
    ' the second it is "xlByColumns". So the first find the first row with a value and the 
    ' second the first column with a value. If the data is arranged in a neat rectangle, the 
    ' last row and the last column will be for the same cell. But if the data is not a neat 
    ' rectangle these statements will still the correct results. 
    RowKeepLast = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlFormulas, _ 
           SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
    ColKeepLast = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlFormulas, _ 
           SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 

    Data = .Range(.Cells(1, 1), _ 
        .Cells(RowKeepLast, ColKeepLast)).Value 

    End With 

    ' Output all the unique sets 
    Debug.Print "Unique Sets" 
    For RowUnqCrnt = 1 To UBound(UniqueSets, 1) 
    Debug.Print UniqueSets(RowUnqCrnt, 1) 
    Next 

    ' Output the first 20 rows of the data 

    ' This will ReDim Headings as an array with a lower bound of 0 
    Headings = VBA.Array("SN", "Set", "FF", "VHCC", "VHCCMID", "VHCVMID", _ 
         "VHCV1", "VHCV2", "VHCV3", "VHCV4", "VHCV5") 

    ReDim ColWidths(1 To UBound(Data, 2)) 

    ' Caluclate maximum width of each column 
    For ColKeepCrnt = 1 To UBound(Data, 2) 
    ColWidths(ColKeepCrnt) = Len(Headings(ColKeepCrnt - 1)) 
    Next 
    For RowKeepCrnt = 1 To 20   ' Replace 20 by Ubound(Data, 1) to include all rows 
    For ColKeepCrnt = 1 To ColKeepLast 
     If ColWidths(ColKeepCrnt) < Len(Data(RowKeepCrnt, ColKeepCrnt)) Then 
     ColWidths(ColKeepCrnt) = Len(Data(RowKeepCrnt, ColKeepCrnt)) 
     End If 
    Next 
    Next 

    ' Output data 
    Debug.Print "Data" 
    Debug.Print "|"; 
    For ColKeepCrnt = 1 To ColKeepLast 
    Debug.Print PadR(Headings(ColKeepCrnt - 1), ColWidths(ColKeepCrnt)) & "|"; 
    Next 
    Debug.Print 
    For RowKeepCrnt = 1 To 20 
    Debug.Print "|"; 
    For ColKeepCrnt = 1 To ColKeepLast 
     Debug.Print PadR(Data(RowKeepCrnt, ColKeepCrnt), ColWidths(ColKeepCrnt)) & "|"; 
    Next 
    Debug.Print 
    Next 

End Sub 
Function PadR(ByVal Str As String, ByVal PadLen As Long) As String 

    If Len(Str) >= PadLen Then 
    ' Do not truncate over length strings 
    PadR = Str 
    Else 
    PadR = Left$(Str & Space(PadLen), PadLen) 
    End If 

End Function