Как пофильтровать в памяти?, Работа с массивами

[claus]

Собственно надо взять с первой колонки все уникальные значения, но...
Есть фрагмент кода, который все что есть в этой колонке заносит в массив:

Код: Выделить всё

KolCells = .Cells(1, 1).End(xlDown).Row
KolID = KolCells
ReDim ID(KolCells)
For ICells = 1 To KolCells
ID(ICells) = .Cells(ICells, 1)

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

Подсказали пойти типа таким путем:

Код: Выделить всё

    .Cells(1, 1).Select
    Selection.Insert Shift:=xlDown
    .Cells(1, 1).Select
    ActiveCell.FormulaR1C1 = ???
    .Select
    .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Cells(1, 1).Select
    Selection.Delete Shift:=xlUp
KolCells = .Cells(1, 1).End(xlDown).Row
KolID = KolCells
ReDim ID(KolCells)
For ICells = 1 To KolCells
ID(ICells) = .Cells(ICells, 1)
    ActiveSheet.ShowAllData

Как это заставить работать?
Кто может помочь?

[claus]

[claus]

Ладно, без вас разобрался. Ну очень отзывчивый форум.

[Viper]

Ладно, без вас разобрался. Ну очень отзывчивый форум.

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

[KL]

Пардон, код бракованный.
Вот решение без циклов:

Код: Выделить всё

Sub test()
    Dim arr As Variant
    With ActiveSheet
        '.Cells(.Rows.Count, 1).End(xlUp) на случай если есть пустые строки
        With .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
            .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
           ' Resize и Offset для того, чтобы исключить заголовки
           ' Application.Transpose для одномерного массива
          arr = Application.Transpose(.Offset(1).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible).Value)
        End With
        .ShowAllData
    End With
End Sub

[claus]

Да не жалко.

Код: Выделить всё

Private Sub CommandButton1_Click()

     Dim MyPath As String 'Путь
     Dim MyFileName As String 'Название файл(ов) которые мы будем открывать
     Dim MyFileName_ As String 'Название файл(ов) которые мы будем открывать
     Dim ID() As Integer 'Массив ID которые по которым мы будет собирать данные
     Dim KolID As Integer 'Произвольное к-во ID?
     Dim KolCells As Integer 'Количество строчек по которым мы будет искать данные
     Dim KolRows As Integer 'Количество столбцов по которым мы будет искать данные
     Dim ICells As Integer, JCells As Integer, ICellsID ' Счетчикu для цикла
     Dim WorkMas() As String
     Dim MasStat() As Integer
     Dim Counter As Integer
     Dim theRange As Range
     Dim uniqueValues As New Collection
     Dim i As Integer
     Dim theArray() 'вот ваш массив
     Dim item As Variant
     Counter = 0
     MyPath_ = "C:\bd\"
     MyPath = "C:\xls\"
     'MyFile = Application.GetOpenFilename("(*.xls),*.xls")
     'MyFileName = MyFile 'Пишем имя файла в ктором храняться ID
     'Workbooks.Open(MyFileName).Activate 'Открываем нужную нам книгу
        ' With ActiveWorkbook.ActiveSheet

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Call ImportTXT
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With ActiveWorkbook.ActiveSheet
            KolCells = .Cells(1, 1).End(xlDown).Row
            KolID = KolCells
            ReDim ID(KolCells)
            For ICells = 1 To KolCells
                            ID(ICells) = .Cells(ICells, 1)
            'все что есть в первом столбце заносим в массив
            Next ICells
End With
''''''''''''''''''''''''''

    Columns("A:A").ClearContents

     MyFileName_ = "BD.xls" 'Пишем имя файла базы данных
     Workbooks.Open(MyPath_ & "\" & MyFileName_).Activate 'Открываем нужную нам книгу
         With ActiveWorkbook.ActiveSheet
             KolCells = .Cells(1, 1).End(xlDown).Row
             KolRows = .Cells(1, 1).End(xlToRight).Column
             ReDim WorkMas(KolCells, KolRows)
             For ICells = 1 To KolCells
                 For ICellsID = 1 To KolID
If .Cells(ICells, 1) = ID(ICellsID) Then
                         Counter = Counter + 1
                         For JCells = 1 To KolRows
                             WorkMas(Counter, JCells) = .Cells(ICells, JCells)

                         ' Если тут есть нужный нам ID то заносим его в память
                         Next JCells
End If
                 Next ICellsID
             Next ICells
         End With
     ActiveWindow.Close 'Закрываем книгу
     ' Все что нам надо у нас есть в памяти=))
     'Все что есть выводим
     ReDim MasStat("20")
     For ICells = 1 To Counter
         For JCells = 1 To KolRows

             If WorkMas(ICells, JCells) = "Значение1" Then MasStat(1) = MasStat(1) + 1
             If WorkMas(ICells, JCells) = "Значение2" Then MasStat(2) = MasStat(2) + 1
             Cells(ICells, JCells) = WorkMas(ICells, JCells)

         Next JCells
     Next ICells

             End Sub
             
             
             Sub ImportTXT()
        Cells(1, 1).Select
        Application.ScreenUpdating = False
         
        MyFile = Application.GetOpenFilename("(*.txt),*.txt)")
     
        If MyFile = False Then Exit Sub
     
        Workbooks.OpenText Filename:=MyFile, Origin:=866, StartRow:=1, _
            DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _
            :=True, Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other _
            :=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:= _
            True
         
        MyFile = ActiveWorkbook.Name
        Workbooks(MyFile).Sheets(1).UsedRange.AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=ThisWorkbook.Sheets("Лист1").Range("A1"), Unique:=True
         
        Application.DisplayAlerts = False
         
        Workbooks(MyFile).Close
         
        Application.DisplayAlerts = True
         
        Application.ScreenUpdating = True
     
End Sub