Компьютерный форум
Правила
Вернуться   Компьютерный форум > Форум программистов > Программирование под Windows > Visual Basic
Перезагрузить страницу Помощь в доработке поиска в Excel
Ответ
 
Опции темы Опции просмотра
  (#1 (permalink)) Старый
CiViS CiViS вне форума
Новичок
 
Сообщений: 1
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 26.05.2016
По умолчанию Помощь в доработке поиска в Excel - 26.05.2016, 13:54

Доброго времени суток)

Нашел в сети вариант поиска по Excel, который почти меня устраивает для заполнения таблицы.
В нем есть один недостаток. При наборе точного наименования отфильтрованные данные из выпадающего списка сбрасываются, приходится удалять последнюю букву чтобы скролом найти нужную позицию.
Хотелось бы что при точном наборе в списке оставался именно введенный вариант.
Помогите пожалуйста)

Код поиска:
vb Код:
Option Explicit
Const minW = 170
Const minH = 15
Public NamedRange       As String
Public LinkedCell       As Range
Public List             As Range
Public L                As Long
Public T                As Long
Public W                As Long
Public H                As Long
Public CodeChange       As Boolean


Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
 
Private Declare Function DrawMenuBar Lib "user32" ( _
ByVal hwnd As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const HWND_DESKTOP As Long = 0
Private Const LOGPIXELSY As Long = 90
Private Const LOGPIXELSX As Long = 88

Const TWIPSPERINCH = 1440

Private Declare Function SystemParametersInfo Lib "user32" _
      Alias "SystemParametersInfoA" _
    (ByVal uAction As Long, _
      ByVal uParam As Long, _
      lpvParam As Any, _
      ByVal fuWinIni As Long) As Long

Sub ShowForm()
    If UserForm1.Caption = "UserForm1" Then _
    UserForm1.Show ' show the form
End Sub

Sub ButtonLaunch()
' Change Range(...) to yours
Dim Target      As Range
On Error Resume Next
Set Target = ActiveCell
If Intersect(Target, Range("B4:B500")) _
    Is Nothing Or Target.Cells.Count > 1 Then
    Exit Sub
End If
SetList
Call DetectDimentions(Target)
Call SetLinkedCell(Target)
ShowForm
End Sub

Sub DetectDimentions(Ran As Range)
Dim S       As Shape
Dim C       As Range
Dim TwX     As Long
Dim TwY     As Long
Dim CorrX   As Long
Dim CorrY   As Long
Dim ScrRow  As Long
Dim ScrCol  As Long
Dim Cls     As Range
Dim Ros     As Range
Dim Zoom    As Integer

TwX = TwipsPerPixelX
TwY = TwipsPerPixelY
Set C = Cells(1, 1)
Set S = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 1, 1)
S.Top = C.Top
S.Left = C.Left

' find correction
Zoom = ActiveWindow.Zoom
ActiveWindow.Zoom = 100
ScrRow = ActiveWindow.ScrollRow
ScrCol = ActiveWindow.ScrollColumn
If ActiveWindow.ScrollRow > 1 Then
Set Cls = Range(Cells(1, 1), Cells(ScrRow - 1, 1))
CorrY = Cls.Height * 20 / TwX
End If
If ActiveWindow.ScrollColumn > 1 Then
Set Ros = Range(Cells(1, 1), Cells(1, ScrCol - 1))
CorrX = Ros.Width * 20 / TwX
End If

With ActiveWindow
    L = .PointsToScreenPixelsX(S.Left) + CorrX
    T = .PointsToScreenPixelsY(S.Top) + CorrY
End With
ActiveWindow.Zoom = Zoom
L = L * TwX / 20
T = T * TwY / 20

With Ran
    W = .Width
    If W < minW Then W = minW
    H = .Height
    If H < minH Then H = minH
End With

S.Delete

End Sub

Sub SetLinkedCell(Target As Range)
    Set LinkedCell = Target
End Sub

Sub SetList()
NamedRange = "Regions"
On Error Resume Next
    Set List = Range(NamedRange)
If Err.Number <> 0 Then
    MsgBox "Диапазона [" & NamedRange & "] не существует =("
    End
End If
End Sub

Public Function InList(Find As String, List As Range)
    InList = Application.Match(Find, List, 0)
    If IsError(InList) Then InList = False
End Function


Sub PopulateList(CB As MSForms.ListBox, List As Range, CBval As String)
    Dim Cel     As Range
    CB.Clear
    If CBval = "" Or InList(CBval, List) Then
        For Each Cel In List
            CB.AddItem Cel
        Next Cel
    Else
        CBval = UCase(CBval)
        For Each Cel In List
            If InStr(1, UCase(Cel), CBval) Then _
                CB.AddItem Cel
        Next Cel
    End If
End Sub

Sub RemoveCaption(objForm As Object)
     
    Dim lStyle          As Long
    Dim hMenu           As Long
    Dim mhWndForm       As Long
     
    If Val(Application.Version) < 9 Then
        mhWndForm = FindWindow("ThunderXFrame", objForm.Caption) 'XL97
   Else
        mhWndForm = FindWindow("ThunderDFrame", objForm.Caption) 'XL2000+
   End If
    lStyle = GetWindowLong(mhWndForm, -16)
    lStyle = lStyle And Not &HC00000
    SetWindowLong mhWndForm, -16, lStyle
    DrawMenuBar mhWndForm
     
End Sub

Public Function TwipsPerPixelX()
  Dim lngDC As Long
 
  lngDC = GetDC(HWND_DESKTOP)
  TwipsPerPixelX = TWIPSPERINCH / GetDeviceCaps(lngDC, LOGPIXELSX)
  ReleaseDC HWND_DESKTOP, lngDC
End Function
 
Public Function TwipsPerPixelY()
  Dim lngDC As Long
 
  lngDC = GetDC(HWND_DESKTOP)
  TwipsPerPixelY = TWIPSPERINCH / GetDeviceCaps(lngDC, LOGPIXELSY)
  ReleaseDC HWND_DESKTOP, lngDC
End Function

Форма к нему:
vb Код:
Const ListBoxH = 100
Option Explicit
Private Sub ListBox1_Change()
If ListBox1.ListIndex > -1 Then
    If ListBox1.Value <> TextBox1.Value Then
        CodeChange = True
        TextBox1.Value = ListBox1.Value
    End If
End If
End Sub
Sub EndForm()
    LinkedCell = ListBox1.Value
    Unload Me
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    EndForm
End Sub

Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 13
    EndForm
Case 38
    If ListBox1.ListIndex = 0 Then TextBox1.SetFocus
End Select
End Sub

Private Sub TextBox1_Change()
If CodeChange Then
    CodeChange = False
Else
    LinkedCell.Value = TextBox1.Value
    Call PopulateList(UserForm1.ListBox1, List, TextBox1.Value)
End If
End Sub

Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 18
    ListBox1.Value = ""
Case 40
    If ListBox1.ListCount > 0 Then
        ListBox1.ListIndex = 0
        ListBox1.SetFocus
    End If
End Select
End Sub

Private Sub UserForm_Terminate()
    If InList(LinkedCell.Value, List) = False Then
        LinkedCell.Value = ""
    End If
End Sub
Private Sub UserForm_Initialize()
    Call RemoveCaption(Me)
End Sub
Private Sub UserForm_Activate()
    With UserForm1
        .Top = T
        .Left = L
        .Width = W + 4
        .Height = H + ListBoxH - 4
    End With
    With ListBox1
        .Top = H
        .Left = 0
        .Width = W
        .Height = ListBoxH
    End With
    With TextBox1
        .Top = 0
        .Left = 0
        .Width = W
        .Height = H + 5
        .Value = LinkedCell.Value
    End With
    If LinkedCell.Value = "" Then _
    Call PopulateList(UserForm1.ListBox1, List, TextBox1.Value)
End Sub
Ответить с цитированием
Ads
Ответ

Опции темы
Опции просмотра

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.
Trackbacks are Вкл.
Pingbacks are Вкл.
Refbacks are Выкл.


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Работа с результатами поиска в Excel Egorro Visual Basic 20 26.02.2016 22:29
Алгоритм поиска c++ takeShy Задания за деньги 2 12.05.2013 12:51
программа для поиска драйверов melman559 Драйвера 3 17.08.2011 23:15
Организация поиска по реестру Shturmovik Вопросы начинающих программистов 3 20.01.2007 12:03
Как Бд использовать для поиска iosin Prolog 2 15.10.2005 14:18
Не сохраняется файл в Excel XP после сохранения в Excel 2003 AleksME Visual Basic 0 13.09.2005 17:15
Диалог для поиска каталога Echo WinAPI 1 08.08.2005 11:25
Как заставить работать проект Excel 2002 в Excel 20023? Alex25 Visual Basic 3 21.07.2005 01:03
Реализация поиска в приложении hendolf .NET 1 23.08.2004 13:59
Организация поиска по столбам в Excel DeusEx C++ Builder 4 01.06.2004 08:19
HELP!!! Нужна помощь... Как сделать диаграмму excel?? imported_tolyan PHP 1 20.06.2003 18:28



Powered by vBulletin® Version 3.8.7
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Нardforum.ru - компьютерный форум и программирование, форум программистов