Private Declare Function GetDC Lib 'user32.dll' (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib 'gdi32.dll' (ByVal HDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib 'user32.dll' (ByVal hwnd As Long, ByVal HDC As Long) As Long


Private Const LOGPIXELSX   As Long = 88
Private Function PointsPerPixel() As Double


    Dim HDC As Long
    Dim lngPotsPerInch As Long
    HDC = GetDC(0)
    lngPotsPerInch = GetDeviceCaps(HDC, LOGPIXELSX)
    PointsPerPixel = Application.InchesToPoints(1) / lngPotsPerInch
    ReleaseDC 0, HDC
End Function


Private Sub Worksheet_SelectionChange(ByVal T As Range)


    Dim rng As Range, x As Single, y As Single, DZoom As Single
    If T.Column = 2 And T.Count = 1 Then
  Set rng = ActiveCell
  With ActiveWindow
   DZoom = .Zoom / 100
   x = .PointsToScreenPixelsX((rng.Left + rng.Width) / PointsPerPixel * DZoom)
   y = .PointsToScreenPixelsY((rng.Top) / PointsPerPixel * DZoom)
  End With


  With 界面
   If .Visible = False Then .Show 0
   .Move x * PointsPerPixel, y * PointsPerPixel
  End With
  Set rng = Nothing
    Else
  Unload 界面
    End If
End Sub


Option Explicit


Private Sub CommandButton1_Click()
   Dim arr1, x, k, arr2(), kk, y
   On Error GoTo 100
   arr1 = Sheets('快捷錄入數(shù)據(jù)源').Range('A1').CurrentRegion
   For x = 1 To UBound(arr1)
  If VBA.InStr(1, arr1(x, 1), Me.TextBox1.Text) <> 0 Then
   k = k + 1
  End If
   Next x
   ReDim arr2(1 To k, 1 To UBound(arr1, 2))
   For x = 1 To UBound(arr1)
   If VBA.InStr(1, arr1(x, 1), Me.TextBox1.Text) <> 0 Then
   kk = kk + 1
   For y = 1 To UBound(arr1, 2)
    arr2(kk, y) = arr1(x, y)
   Next y
  End If
   Next x
   With Me.ListBox1
  .ColumnCount = UBound(arr1, 2)
  .List = arr2
  .ColumnWidths = '2厘米;1厘米;1厘米;1厘米'
    End With
    Exit Sub
100:
    MsgBox '搜索不到: ' & Me.TextBox1.Text
    Me.TextBox1 = ''
End Sub


Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim a, z
    a = Me.ListBox1.ListIndex
    For z = 1 To 4
  ActiveCell.Offset(0, z - 1) = Me.ListBox1.List(a, z - 1)
    Next z


End Sub

立即關(guān)注

影風(fēng) LV2 2樓

天天好心情 LV2 3樓

蒲公英 LV2 4樓

塵封記憶 LV2 5樓