 佛山小老鼠楼主【 Excel分享】快速录入数据工具(附源代码) 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('快捷录入数据源').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 |
|
|
来自： 刀丛里觅诗 > 《数据处理excel》
