深夜发个处女求助贴，窗体模糊找查录入，我相信这里会有高手出现的

qcw911 · 发表于 2019-4-23 09:11

第一眼看成处女深夜发帖。。。。。

vspon · 发表于 2019-4-23 11:28

爱吃蜂蜜的狼发表于 2019-4-22 20:34
试下这个，只是个草稿。

在此谢谢你了，想不到你会做那么多功能，真的很意外，需然和我想的有些不同，不知道能不能修改下呢？录入只需要录到入库单就可以了，不用把数据写进出入库记录表里的，

hzruziniu · 发表于 2019-4-23 11:32

'窗体代码如下：
Private arr '窗体公共数组
'==============初始化
Private Sub UserForm_Initialize()
Dim Myr&, i&
With Sheets("物品库")
Myr = .Range("b65536").End(xlUp).Row
arr = .Range("b5:e" & Myr) '把物品装入数组
End With
With ListView1
.ColumnHeaders.Clear '清除原设置
.ListItems.Clear '清除列表
.View = lvwReport ' listivew的显示格式为报表格式
.FullRowSelect = True ' 允许整行选中
.Gridlines = True ' 显示网格线
.CheckBoxes = True ' 显示复选框
End With
For i = 2 To 5 '自动设置标题列(列宽按原始表大小)
ListView1.ColumnHeaders.Add , , Sheets("物品库").Cells(5, i), Width:=Sheets("物品库").Cells(5, i).Width 'ListView1标题=第5行，宽=工作表列宽
Next i
For i = 1 To UBound(arr) '列表赋值 '
With ListView1.ListItems.Add(, , arr(i, 1)) '数据显示的开始位置
For y = 2 To UBound(arr, 2)
.SubItems(y - 1) = arr(i, y) '这个1不能变
Next y
End With
Next i
OptionButton1.Value = True
End Sub
'=============================模糊查找
Private Sub TextBox1_Change()
Dim s$, i&, x&, j&
s = Me.TextBox1.Value
If Len(s) = 0 Then s = "*"
With Me.ListView1
.ListItems.Clear
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If arr(i, j) Like s Or InStr(arr(i, j), s) > 0 Or InStr(arr(i, j), UCase(s)) > 0 Then '数字表示第二列
With .ListItems.Add(, , arr(i, 1)) '开始的位置
For x = 2 To UBound(arr, 2) ''''2
.SubItems(x - 1) = arr(i, x)
Next x
End With
Exit For
End If
Next
Next i
End With
End Sub
'==================================单选录入
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim h&, y&, r&
On Error Resume Next
With ListView1
h = Range("B65536").End(3).Row + 1
y = ActiveCell.Row '选中的活动单元格行号
r = .SelectedItem.Index
If OptionButton1.Value Then
' r = .SelectedItem.Index
Cells(h, 2) = .ListItems.Item(r)
For i = 1 To 3
Cells(h, i + 2) = .ListItems(r).SubItems(i)
Next
Unload Me
End If
End With
End Sub
'==============================多选录入
Sub 多选录入()
With Me.ListView1
If .ListItems.Count = 0 Then Exit Sub
.ListItems(1).Ghosted = False
r = Range("b65536").End(3).Row '最大行数
For i = 1 To .ListItems.Count
If .ListItems(i).Checked Then
r = r + 1
.ListItems(i).Checked = False
With ActiveSheet
.Cells(r, 2).Offset(0, 0) = ListView1.ListItems(i).Text
For j = 1 To 3
.Cells(r, 2).Offset(0, j) = ListView1.ListItems(i).SubItems(j)
Next
End With
End If
Next i
End With
Unload Me
End Sub
'===================双击启用多选录入
Private Sub ListView1_DblClick()
多选录入
Unload Me
End Sub
'==================按扭多选录
Private Sub CommandButton1_Click()
多选录入
Unload Me
End Sub
'==================退出
Private Sub CommandButton2_Click()
Unload Me
End Sub

复制代码

hzruziniu · 发表于 2019-4-23 11:35

vspon 发表于 2019-4-23 11:28
在此谢谢你了，想不到你会做那么多功能，真的很意外，需然和我想的有些不同，不知道能不能修改下呢？录入 ...

进销存.rar (75.71 KB, 下载次数: 15)

vspon · 发表于 2019-4-23 12:06

hzruziniu 发表于 2019-4-23 11:35

我打开怎么用不了呢？？？帮忙看看那里有问题

vspon · 发表于 2019-4-23 12:17

vspon 发表于 2019-4-23 12:06
我打开怎么用不了呢？？？帮忙看看那里有问题

要什么控件支持呢，，我的电脑提示无法安装对象，

hzruziniu · 发表于 2019-4-23 13:20

vspon 发表于 2019-4-23 12:17
要什么控件支持呢，，我的电脑提示无法安装对象，

你的系统可能没有 ListView 这个控件，需要激活或安装

hzruziniu · 发表于 2019-4-23 16:39

本帖最后由 hzruziniu 于 2019-4-23 16:43 编辑

进销存.rar (78.78 KB, 下载次数: 25)
换一个ListBpx控件设置，这个控件肯定可以用了，窗体请点击出库表的B列
代码如下：

Option Explicit
Private Arr '公有数组
Dim Sht1 As Worksheet, Myr&
'==============初始化
Private Sub UserForm_Initialize()
Dim k, d
Set Sht1 = Worksheets("物品库")
Myr = Sht1.[B65536].End(xlUp).Row
Arr = Sht1.Range("b5:e" & Myr)
With Me.ListBox1
.ColumnCount = 4
.ColumnWidths = "80,150,150,70"
.ListStyle = fmListStyleOption '显示选项图标
.MultiSelect = 0 '显示单选项
' .MultiSelect = 1 '显示复选项
.List = Arr
End With
OptionButton1.Value = True
End Sub
'==============单行录入
Private Sub ListBox1_Click()
Dim n&, j&, y&
With ListBox1
If OptionButton1.Value Then
n = Range("B65536").End(3).Row + 1
Else
n = ActiveCell.Row '选中的活动单元格行号
End If
For j = 0 To 3
Cells(n, j + 2) = ListBox1.List(ListBox1.ListIndex, j)
Next
' Unload Me
End With
End Sub
'===================勾选复选框多行录入
Sub 多选录入()
Dim brr, i&, j&, k&, r&
ReDim brr(1 To ListBox1.ListCount, 1 To 4)
With ListBox1
If .ListCount < 1 Then Exit Sub
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
k = k + 1
For j = 1 To 4
brr(k, j) = .List(i, j - 1)
Next
End If
Next
End With
Sheet4.Activate
r = Range("b65536").End(3).Row + 1
'Cells.ClearContents
Cells(r, 2).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub
Private Sub CommandButton1_Click()
多选录入
Unload Me
End Sub
'==================勾选单选控件
Private Sub OptionButton1_Click()
With ListBox1
If OptionButton1.Value = True Then
.MultiSelect = 0 '显示单选项
Else
.MultiSelect = 1 'Click() 触发事件
End If
End With
End Sub
'==================勾选复选（多选）控件
Private Sub OptionButton2_Click()
With ListBox1
If OptionButton2.Value = True Then
.MultiSelect = 1 '显示复选项
Else
.MultiSelect = 2 'Click() 不触发事件
End If
End With
End Sub
'=================模糊查找生成列表
Private Sub TextBox1_Change()
Dim s As String, j&, n&, x&, i&
Dim brr()
' Call zb
s = TextBox1.Text
With ListBox1
If TextBox1.Value <> "" Then
ReDim brr(1 To UBound(Arr), 1 To 4)
For i = 1 To UBound(Arr)
If Arr(i, 1) Like "*" & s & "*" Or Arr(i, 2) Like "*" & s & "*" Or Arr(i, 3) Like "*" & s & "*" Or Arr(i, 4) Like "*" & s & "*" Then
n = n + 1
For j = 1 To 4
brr(n, j) = Arr(i, j)
Next
End If
Next i
.List = brr
Else
.List = Arr
End If
End With
' Label1.Caption = "共找到 " & n & " 条记录"
End Sub
'==================退出
Private Sub CommandButton2_Click()
Unload Me
End Sub

复制代码

vspon · 发表于 2019-4-23 17:05

hzruziniu 发表于 2019-4-23 16:39
换一个ListBpx控件设置，这个控件肯定可以用了，窗体请点击出库表的B列
代码如下：

这个我电脑能用，你太让我惊讶了，绝对的精品，我都不敢想象你还会再次去再做，因为很多人都是怕麻烦的，真的想不到，你会那么用心去做，，谢谢！谢谢！谢谢！谢谢！谢谢！谢谢！谢谢！谢谢！谢谢！谢谢！谢谢！

		自动登录	找回密码
密码			免费注册

[求助] 深夜发个处女求助贴，窗体模糊找查录入，我相信这里会有高手出现的

评分

评分

评分