Visual Basic, .NET, ASP, VBScript
Новости | Примеры | Библиотека кодов | НеЧаВо | VBA | Справочник по VB | Справочник по WinAPI | ActiveX контролы | Статьи по VB | Мастерская разработчика | Форум VBNet | Яndex bar! | Голосование | Полезные программы | Магазин VBNet | Рассылка | Конкурсы | Юмор | Чат | Реклама на VBNet | Автора! | Ссылки | Бета-тестирование | Послать пример на сайт
 

   
   
     

Форум - VBA

Страница: 1 | 2 | 3 |

 

  Вопрос: Как пофильтровать в памяти? Добавлено: 16.10.08 14:50  

Автор вопроса:  quest
Собственно надо взять с первой колонки все уникальные значения, но...
Есть фрагмент кода, который все что есть в этой колонке заносит в массив:
KolCells = .Cells(1, 1).End(xlDown).Row
KolID = KolCells
ReDim ID(KolCells)
For ICells = 1 To KolCells
ID(ICells) = .Cells(ICells, 1)

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

Ответить

  Ответы Всего ответов: 31  

Номер ответа: 1
Автор ответа:
 s12



Вопросов: 24
Ответов: 363
  Профиль | | #1 Добавлено: 16.10.08 15:14
Отсортируй колонку, затем перед внесением в массив проверяй равен ли следующий элемент последнему в массиве, если да то элемент побоку, иначе добавляем. По моему быстрее не сделать.

Ответить

Номер ответа: 2
Автор ответа:
 quest



Вопросов: 5
Ответов: 34
  Профиль | | #2 Добавлено: 16.10.08 15:29
Мне колонку нельзя менять.

Ответить

Номер ответа: 3
Автор ответа:
 mc-black



ICQ: 308-534-060 

Вопросов: 20
Ответов: 1860
  Web-сайт: mc-black.narod.ru/dzp.htm
 Профиль | | #3 		Добавлено: 16.10.08 15:37
Вот и работай с этим массивом: сортируй этот массив (или его копию) и сделай, как тебе пишет s12 в первом ответе.

Ответить

Номер ответа: 4
Автор ответа:
 quest



Вопросов: 5
Ответов: 34
  Профиль | | #4 Добавлено: 16.10.08 16:11
Неасилил

Ответить

Номер ответа: 5
Автор ответа:
 quest



Вопросов: 5
Ответов: 34
  Профиль | | #5 Добавлено: 16.10.08 16:28
Если как-то вот так, только чтобы работало:
  1.     .Cells(1, 1).Select
  2.     Selection.Insert Shift:=xlDown
  3.     .Cells(1, 1).Select
  4.     ActiveCell.FormulaR1C1 = ???
  5.     .Select
  6.     .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
  7.     .Cells(1, 1).Select
  8.     Selection.Delete Shift:=xlUp
  9. KolCells = .Cells(1, 1).End(xlDown).Row
  10. KolID = KolCells
  11. ReDim ID(KolCells)
  12. For ICells = 1 To KolCells
  13. ID(ICells) = .Cells(ICells, 1)
  14.     ActiveSheet.ShowAllData

Ответить

Номер ответа: 6
Автор ответа:
 Nytrogen



Вопросов: 18
Ответов: 186
  Профиль | | #6 Добавлено: 16.10.08 17:58
Я бы через коллекцию сделал. Имхо, меньше мороки и красиво.
Option Explicit
Option Base 1

Sub SelectUniqueValues()
  Dim theRange As Range
  Dim uniqueValues As New Collection
  Dim i As Integer
  Dim theArray()
  Dim item As Variant

  'запоминаем диапазон
  Set theRange = Range("A1", Range("A1";).End(xlDown).Address)
  With theRange
    'игнорируем ошибку при добавлении повторяющегося значения
    On Error Resume Next
    For i = 1 To .Rows.Count
      uniqueValues.Add .Cells(i, 1).Value, .Cells(i, 1).Value
    Next i
    On Error GoTo 0
  End With

  'перекидываем значения коллекции в массив
  ReDim Preserve theArray(uniqueValues.Count)
  i = 1
  For Each item In uniqueValues
    theArray(i) = item
    i = i + 1
  Next item

End Sub

Ответить

Номер ответа: 7
Автор ответа:
 mai



Вопросов: 0
Ответов: 24
  Профиль | | #7 Добавлено: 17.10.08 01:07
Попробуйте расширенный фильтр. Там есть возможность отфильтровать только уникпальные сроки.

Ответить

Номер ответа: 8
Автор ответа:
 mai



Вопросов: 0
Ответов: 24
  Профиль | | #8 Добавлено: 17.10.08 01:08
Извините, описка. Только уникальные строки.

Ответить

Номер ответа: 9
Автор ответа:
 mai



Вопросов: 0
Ответов: 24
  Профиль | | #9 Добавлено: 17.10.08 01:09
Извините, описка. Только уникальные строки.

Ответить

Номер ответа: 10
Автор ответа:
 quest



Вопросов: 5
Ответов: 34
  Профиль | | #10 Добавлено: 17.10.08 12:55
Не, не вышло, то есть я написаное Вами попытался вставить через Application.Run, и без толку.
Вот собственно все вместе - исходник, куда вставить фильтр надо - там RED.txt с описанием: http://garden.gov.ua/failo/xls.rar

Ответить

Номер ответа: 11
Автор ответа:
 mai



Вопросов: 0
Ответов: 24
  Профиль | | #11 Добавлено: 17.10.08 13:54
Расширенный фильтр - главное меню - данные - фильтр - расширенный фильтр
Попробуйте вручную, а потом запишите макрос.

Ответить

Номер ответа: 12
Автор ответа:
 quest



Вопросов: 5
Ответов: 34
  Профиль | | #12 Добавлено: 17.10.08 14:06
Да не, это слишком просто, чтобы быть правдой - как записать макрос я знаю :) - мне исходник менять нельзя - потому и исчу способ, как это сделать не на листе, а в памяти.

Ответить

Номер ответа: 13
Автор ответа:
 Nytrogen



Вопросов: 18
Ответов: 186
  Профиль | | #13 Добавлено: 17.10.08 15:30
Зачем Вам Application.Run? В Вашем основном макросе напишите вот так

Option Explicit
Option Base 1

Sub SelectUniqueValues()
  Dim theRange As Range
  Dim uniqueValues As New Collection
  Dim i As Integer
  Dim theArray()
  Dim item As Variant

  'запоминаем диапазон ИЗ ДРУГОЙ КНИГИ
  Set theRange = Workbooks.Open("C:\xls\16.xls";).Worksheets(1).Range("A1";).Range("A1", Range("A1";).End(xlDown).Address)
  With theRange
    'игнорируем ошибку при добавлении повторяющегося значения
    On Error Resume Next
    For i = 1 To .Rows.Count
      uniqueValues.Add .Cells(i, 1).Value, .Cells(i, 1).Value
    Next i
    On Error GoTo 0
  End With

  'перекидываем значения коллекции в массив
  ReDim Preserve theArray(uniqueValues.Count)
  i = 1
  For Each item In uniqueValues
    theArray(i) = item
    i = i + 1
  Next item

End Sub

Ответить

Номер ответа: 14
Автор ответа:
 quest



Вопросов: 5
Ответов: 34
  Профиль | | #14 Добавлено: 17.10.08 16:31
Пишет Invald ns de procedure.
Весь мой код выглядит вот так:
  1.     Private Sub CommandButton1_Click()
  2.  
  3.     Dim MyPath As String 'Путь
  4.     Dim MyFileName As String 'Название файл(ов) которые мы будем открывать
  5.     Dim MyFileName_ As String 'Название файл(ов) которые мы будем открывать
  6.     Dim ID() As Integer 'Массив ID которые по которым мы будет собирать данные
  7.     Dim KolID As Integer 'Произвольное к-во ID?
  8.     Dim KolCells As Integer 'Количество строчек по которым мы будет искать данные
  9.     Dim KolRows As Integer 'Количество столбцов по которым мы будет искать данные
  10.     Dim ICells As Integer, JCells As Integer, ICellsID ' Счетчикu для цикла
  11.     Dim WorkMas() As String
  12.     Dim MasStat() As Integer
  13.     Dim Counter As Integer
  14.     Counter = 0
  15.     MyPath_ = "C:\bd\"
  16.     MyPath = "C:\xls\"
  17.     MyFile = Application.GetOpenFilename("(*.xls),*.xls")
  18.     MyFileName = MyFile 'Пишем имя файла в ктором храняться ID
  19.     Workbooks.Open(MyFileName).Activate 'Открываем нужную нам книгу
  20.         With ActiveWorkbook.ActiveSheet
  21.             
  22.             
  23.             
  24.             KolCells = .Cells(1, 1).End(xlDown).Row
  25.             KolID = KolCells
  26.             ReDim ID(KolCells)
  27.             For ICells = 1 To KolCells
  28.                             ID(ICells) = .Cells(ICells, 1)
  29.             'все что есть в первом столбце заносим в массив
  30.             Next ICells
  31.         
  32.         
  33.         
  34.         End With
  35.     ActiveWindow.Close 'Закрываем книгу
  36.     
  37.     MyFileName_ = "BD.xls" 'Пишем имя файла базы данных
  38.     Workbooks.Open(MyPath_ & "\" & MyFileName_).Activate 'Открываем нужную нам книгу
  39.         With ActiveWorkbook.ActiveSheet
  40.             KolCells = .Cells(1, 1).End(xlDown).Row
  41.             KolRows = .Cells(1, 1).End(xlToRight).Column
  42.             ReDim WorkMas(KolCells, KolRows)
  43.             For ICells = 1 To KolCells
  44.                 For ICellsID = 1 To KolID
  45.                     If .Cells(ICells, 1) = ID(ICellsID) Then
  46.                         Counter = Counter + 1
  47.                         For JCells = 1 To KolRows
  48.                             WorkMas(Counter, JCells) = .Cells(ICells, JCells)
  49.                             
  50.                         ' Если тут есть нужный нам ID то заносим его в память
  51.                         Next JCells
  52.                     End If
  53.                 Next ICellsID
  54.             Next ICells
  55.         End With
  56.     ActiveWindow.Close 'Закрываем книгу
  57.     ' Все что нам надо у нас есть в памяти=))
  58.     'Все что есть выводим
  59.     ReDim MasStat("20")
  60.     For ICells = 1 To Counter
  61.         For JCells = 1 To KolRows
  62.             
  63.             If WorkMas(ICells, JCells) = "Значение1" Then MasStat(1) = MasStat(1) + 1
  64.             If WorkMas(ICells, JCells) = "Значение2" Then MasStat(2) = MasStat(2) + 1
  65.             Cells(ICells, JCells) = WorkMas(ICells, JCells)
  66.             
  67.         Next JCells
  68.     Next ICells
  69.         
  70.             End Sub

И как это сюда вставить, чтобы работало? - Я слишком чайник.

Ответить

Номер ответа: 15
Автор ответа:
 Nytrogen



Вопросов: 18
Ответов: 186
  Профиль | | #15 Добавлено: 17.10.08 17:32
  1.    Private Sub CommandButton1_Click()
  2.  
  3.      Dim MyPath As String 'Путь
  4.      Dim MyFileName As String 'Название файл(ов) которые мы будем открывать
  5.      Dim MyFileName_ As String 'Название файл(ов) которые мы будем открывать
  6.      Dim ID() As Integer 'Массив ID которые по которым мы будет собирать данные
  7.      Dim KolID As Integer 'Произвольное к-во ID?
  8.      Dim KolCells As Integer 'Количество строчек по которым мы будет искать данные
  9.      Dim KolRows As Integer 'Количество столбцов по которым мы будет искать данные
  10.      Dim ICells As Integer, JCells As Integer, ICellsID ' Счетчикu для цикла
  11.      Dim WorkMas() As String
  12.      Dim MasStat() As Integer
  13.      Dim Counter As Integer
  14.      Dim theRange As Range
  15.      Dim uniqueValues As New Collection
  16.      Dim i As Integer
  17.      Dim theArray() 'вот ваш массив
  18.      Dim item As Variant
  19.      Counter = 0
  20.      MyPath_ = "C:\bd\"
  21.      MyPath = "C:\xls\"
  22.      MyFile = Application.GetOpenFilename("(*.xls),*.xls")
  23.      MyFileName = MyFile 'Пишем имя файла в ктором храняться ID
  24.      Workbooks.Open(MyFileName).Activate 'Открываем нужную нам книгу
  25.          With ActiveWorkbook.ActiveSheet
  26.  
  27. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  28.   'запоминаем диапазон
  29.   Set theRange = .Range("A1", .Range("A1").End(xlDown).Address)
  30.   'игнорируем ошибку при добавлении повторяющегося значения
  31.   On Error Resume Next
  32.   For i = 1 To theRange.Rows.Count
  33.     uniqueValues.Add theRange.Cells(i, 1).Value, theRange.Cells(i, 1).Value
  34.   Next i
  35.   On Error GoTo 0
  36.  
  37.   'перекидываем значения коллекции в массив
  38.   ReDim Preserve theArray(uniqueValues.Count)
  39.   i = 1
  40.   For Each item In uniqueValues
  41.     theArray(i) = item
  42.     i = i + 1
  43.   Next item
  44. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  45.  
  46.          End With
  47.      ActiveWindow.Close 'Закрываем книгу
  48.  
  49.      MyFileName_ = "BD.xls" 'Пишем имя файла базы данных
  50.      Workbooks.Open(MyPath_ & "\" & MyFileName_).Activate 'Открываем нужную нам книгу
  51.          With ActiveWorkbook.ActiveSheet
  52.              KolCells = .Cells(1, 1).End(xlDown).Row
  53.              KolRows = .Cells(1, 1).End(xlToRight).Column
  54.              ReDim WorkMas(KolCells, KolRows)
  55.              For ICells = 1 To KolCells
  56.                  For ICellsID = 1 To KolID
  57. If .Cells(ICells, 1) = ID(ICellsID) Then
  58.                          Counter = Counter + 1
  59.                          For JCells = 1 To KolRows
  60.                              WorkMas(Counter, JCells) = .Cells(ICells, JCells)
  61.  
  62.                          ' Если тут есть нужный нам ID то заносим его в память
  63.                          Next JCells
  64. End If
  65.                  Next ICellsID
  66.              Next ICells
  67.          End With
  68.      ActiveWindow.Close 'Закрываем книгу
  69.      ' Все что нам надо у нас есть в памяти=))
  70.      'Все что есть выводим
  71.      ReDim MasStat("20")
  72.      For ICells = 1 To Counter
  73.          For JCells = 1 To KolRows
  74.  
  75.              If WorkMas(ICells, JCells) = "Значение1" Then MasStat(1) = MasStat(1) + 1
  76.              If WorkMas(ICells, JCells) = "Значение2" Then MasStat(2) = MasStat(2) + 1
  77.              Cells(ICells, JCells) = WorkMas(ICells, JCells)
  78.  
  79.          Next JCells
  80.      Next ICells
  81.  
  82.              End Sub



З.Ы. Когда скопируете это в VBE, из-за особенностей "форума" в начале каждой строки появится символ #. Воспользуйтесь стандартным Replace'ом для устранения этой неполадки (комбинация Ctrl + H). Вообще, организация форума оставляет желать лучшего.

Ответить

Страница: 1 | 2 | 3 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам