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

Ответить

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

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



Вопросов: 5
Ответов: 34
  Профиль | | #16 Добавлено: 17.10.08 17:57
А у меня не появилось никаких " #" - это плохо-:)?
Да, работает действительно быстро, только в результате ничего не получаем. :(
Шас буду смотреть почему.

Ответить

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



Вопросов: 18
Ответов: 186
  Профиль | | #17 Добавлено: 17.10.08 17:59
Если не появилось, то радуйтесь =). Что именно мы не получаем в результате?

Ответить

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



Вопросов: 5
Ответов: 34
  Профиль | | #18 Добавлено: 17.10.08 18:06
А у меня не появилось никаких " #" - это плохо-:)?
Да, работает действительно быстро, только в результате ничего не получаем. :(
Шас буду смотреть почему.

Ответить

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



Вопросов: 5
Ответов: 34
  Профиль | | #19 Добавлено: 17.10.08 18:07
изивините, чет движек у форума интереный, дублями бросается )

Ответить

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



Вопросов: 5
Ответов: 34
  Профиль | | #20 Добавлено: 17.10.08 18:12
Если не трудно - http://garden.gov.ua/failo/xls.rar - архивчик, в нем 2 папки - их распаковать в корень С, открыть папку бд и там открыть run.xls, в нем клацнуть кнопку - , предложит открыть файл - взять из папки хлс / 15.тхт или 85. тхт - результат вы сами увидите - много дублей из базы извлекает, а надо по 1 экземпляру. - для чего фильтр и нужен (чтобы из исходника (например 15.тхт) только уникальные значения на обработку взять)

Ответить

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



Вопросов: 5
Ответов: 34
  Профиль | | #21 Добавлено: 17.10.08 18:16
я прошу прощения - 15 или 85 .xls

Ответить

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



Вопросов: 5
Ответов: 34
  Профиль | | #22 Добавлено: 17.10.08 18:23
Мне вот еще таким путе пойти предлагали
  1. Dim ws As Worksheet
  2.     Dim r As Range
  3.     Dim ID() As String
  4.     
  5.     Set ws = ThisWorkbook.Worksheets(2)
  6.     
  7.     kolcells = ThisWorkbook.Worksheets(2).Cells(1, 1).End(xlDown).Row
  8.     
  9.     'оставляем только уникальные значения
  10.     Set r = ws.Range("A1:A" + CStr(kolcells))
  11.     r.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
  12.  
  13.     'кидаем в массив
  14.     ICells = 1
  15.     ReDim ID(kolcells)
  16.     For Each rw In r.Rows
  17.         If Not rw.Hidden Then
  18.             Debug.Print rw.Cells(1).Text
  19.             ID(ICells) = rw.Cells(1).Text
  20.             ICells = ICells + 1
  21.         End If
  22.     Next
  23.     
  24.     For ICells = 1 To kolcells
  25.         Debug.Print ID(ICells)
  26.     Next
  27.     
  28.     'убираем филтр
  29.     ws.ShowAllData

Только тоже не выходит

Ответить

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



Вопросов: 18
Ответов: 186
  Профиль | | #23 Добавлено: 17.10.08 19:34
Вы проверьте, что в массив заносится. В том коде, что я кинул, вставьте в цикл, где в массив перекидывается, Debug.Print:

  For Each item In uniqueValues
    theArray(i) = item
    Debug.Print theArray(i)
    i = i + 1
  Next item


Там должны быть уникальные значения из первой колонки.

Ответить

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



Вопросов: 0
Ответов: 24
  Профиль | | #24 Добавлено: 17.10.08 23:00
Прпробуйте это.

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

Ответить

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



Вопросов: 0
Ответов: 24
  Профиль | | #25 Добавлено: 17.10.08 23:04
С первого раза вышла осечка, попробую еще.
  1. Sub ImportTXT()
  2.         Cells(1, 1).Select
  3.         Application.ScreenUpdating = False
  4.         
  5.         MyFile = Application.GetOpenFilename("(*.txt),*.txt)")
  6.     
  7.         If MyFile = False Then Exit Sub
  8.     
  9.         Workbooks.OpenText Filename:=MyFile, Origin:=866, StartRow:=1, _
  10.             DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _
  11.             :=True, Tab:=True, Semicolon:=False, Comma:=False, Space:=True, Other _
  12.             :=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:= _
  13.             True
  14.         
  15.         MyFile = ActiveWorkbook.Name
  16.         Workbooks(MyFile).Sheets(1).UsedRange.AdvancedFilter Action:=xlFilterCopy, _
  17.         CopyToRange:=ThisWorkbook.Sheets("Лист1").Range("A1"), Unique:=True
  18.         
  19.         Application.DisplayAlerts = False
  20.         
  21.         Workbooks(MyFile).Close
  22.         
  23.         Application.DisplayAlerts = True
  24.         
  25.         Application.ScreenUpdating = True
  26.     
  27. End Sub

Ответить

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



Вопросов: 5
Ответов: 34
  Профиль | | #26 Добавлено: 20.10.08 10:58
Run-time error '1004':
Диaпaзoн выбopки нe имeeт имeни или имeeт нeпpaвильнoe имя
пoля.

Ответить

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



Вопросов: 0
Ответов: 24
  Профиль | | #27 Добавлено: 20.10.08 17:22
Очень интересно. Выдайте секрет, как Вы этого добились.

Ответить

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



Вопросов: 5
Ответов: 34
  Профиль | | #28 Добавлено: 20.10.08 17:33
~ да я и не старался, ради этого, просто попытался совместить то, что было у меня с тем что предложили Вы. Наверное это потому, что я не знаю намного больше чем знаю.

Ответить

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



Вопросов: 5
Ответов: 34
  Профиль | | #29 Добавлено: 20.10.08 17:39
Вот, кстати, еще вариант, как можно профильтровать:
  1. Dim ID() As String
  2. Sub Макрос()
  3. Dim i As Integer, j As Integer, x As Integer
  4. ReDim ID(x)
  5. For i = 1 To Cells(1, 1).End(xlDown).Row
  6.     If test(Cells(i, 1).Text) = False Then
  7.         ReDim Preserve ID(x)
  8.         ID(x) = Cells(i, 1).Text
  9.         x = x + 1
  10.     End If
  11. Next i
  12. For i = LBound(ID) To UBound(ID)
  13.     Cells(i + 1, 2).Value = ID(i)
  14. Next i
  15. End Sub
  16. Private Function test(newID) As Boolean
  17. Dim i As Integer
  18. For i = LBound(ID) To UBound(ID)
  19.     If newID = ID(i) Then test = True: Exit Function
  20. Next i
  21. test = False
  22. End Function
  23.  
  24. Private Sub CommandButton1_Click()
  25. Call Макрос
  26. End Sub


Работает прекрасно, а вставить немогу. http://garden.gov.ua/failo/filtr.zip - то, что сбрасывает в колонку В - надо чтобы брал на обработку

Ответить

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



Вопросов: 0
Ответов: 24
  Профиль | | #30 Добавлено: 20.10.08 18:57
Вставьте мою процедуру в модуль, а в


Private Sub CommandButton1_Click()
Call Макрос  
End Sub


Замените слово Макрос на слово ImportTXT

Ответить

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

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



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