[已解决]需要做一个简单的筛选功能

corient · 发表于 2015-11-13 08:12

本帖最后由爱疯于 2015-11-13 09:02 编辑

各位高手好，
   小弟需要做一个简单的筛选功能：
   1，在EXCEl中已形成了透视表，目的：可以选择供应商编码进行筛选内容；但其他供应商可以看到相互的内容所以我想只有
在输入供应商编码一栏（下面右边）里输入对应的编码才能相应筛选后看到对应的信息（如下格式）。否则看不到任何信息。各位是否可以帮忙编个小程序？谢谢大家了。


供应商编码       301004                      输入供应商编码：       301004       <------在这个格子里输入编码，左面出现相应的编码后进行筛选。

最佳答案

月排行榜 / 总排行榜

神隐汀渚

2015-11-14 11:13

本帖最后由神隐汀渚于 2015-11-14 11:38 编辑

才学的可能比较慢 {:16:}

Sub 供应商信息查询()
Dim i As String, arr(), sht As Worksheet
Range("a2:u300").Clear
i = Application.InputBox("请输入供应商编号", , , , , , , 1)
Dim t As Single
t = Timer
If i = False Then Exit Sub
Set sht = Sheets("物料信息总表")
If WorksheetFunction.CountIf(sht.Range("c1:c1000"), i) = 0 Then
MsgBox "此物料编号不存在"
Exit Sub
End If
arr = sht.Range("a2:u" & sht.Range("a1").End(xlDown).Row)
Dim j As Long, brr(1 To 3000), k As Long
k = 0
For j = 1 To UBound(arr)
If arr(j, 3) = i Then
k = k + 1
brr(k) = sht.Range("a" & j + 1 & ":u" & j + 1)
Range("a" & k + 2 & ":u" & k + 2) = brr(k)
Range("a" & k + 2 & ":u" & k + 2).Select
End If
Next j
Range("a2:u2") = sht.Range("a1:u1").Value
Dim crr(), m As Integer, s As Integer, sums As Double, x As Integer
crr = Range("f3:u" & Range("a2").End(xlDown).Row)
x = Range("a2").End(xlToRight).Column - 4
Application.ScreenUpdating = False
For m = x To 1 Step -1
sums = 0
For s = 1 To Range("a3").End(xlDown).Row - 2
sums = sums + crr(s, m)
Next s
If sums = 0 Then
Columns(Chr(69 + m) & ":" & Chr(69 + m)).Select
Selection.Delete Shift:=xlToLeft
Else: GoTo 1
End If
1:
Next m
Application.ScreenUpdating = True
Range("a2").CurrentRegion.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
With Selection.Font
.Name = "宋体"
.Size = 10
End With
With Selection.Borders
.LineStyle = xlContinuous
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
MsgBox (Format(Timer - t, "0.00000s"))
End Sub

复制代码

跳转到最佳答案楼层

corient · 发表于 2015-11-13 12:19

谢谢各位了！

神隐汀渚 · 发表于 2015-11-14 11:13

本帖最后由神隐汀渚于 2015-11-14 11:38 编辑

才学的可能比较慢 {:16:}

Sub 供应商信息查询()
Dim i As String, arr(), sht As Worksheet
Range("a2:u300").Clear
i = Application.InputBox("请输入供应商编号", , , , , , , 1)
Dim t As Single
t = Timer
If i = False Then Exit Sub
Set sht = Sheets("物料信息总表")
If WorksheetFunction.CountIf(sht.Range("c1:c1000"), i) = 0 Then
MsgBox "此物料编号不存在"
Exit Sub
End If
arr = sht.Range("a2:u" & sht.Range("a1").End(xlDown).Row)
Dim j As Long, brr(1 To 3000), k As Long
k = 0
For j = 1 To UBound(arr)
If arr(j, 3) = i Then
k = k + 1
brr(k) = sht.Range("a" & j + 1 & ":u" & j + 1)
Range("a" & k + 2 & ":u" & k + 2) = brr(k)
Range("a" & k + 2 & ":u" & k + 2).Select
End If
Next j
Range("a2:u2") = sht.Range("a1:u1").Value
Dim crr(), m As Integer, s As Integer, sums As Double, x As Integer
crr = Range("f3:u" & Range("a2").End(xlDown).Row)
x = Range("a2").End(xlToRight).Column - 4
Application.ScreenUpdating = False
For m = x To 1 Step -1
sums = 0
For s = 1 To Range("a3").End(xlDown).Row - 2
sums = sums + crr(s, m)
Next s
If sums = 0 Then
Columns(Chr(69 + m) & ":" & Chr(69 + m)).Select
Selection.Delete Shift:=xlToLeft
Else: GoTo 1
End If
1:
Next m
Application.ScreenUpdating = True
Range("a2").CurrentRegion.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
With Selection.Font
.Name = "宋体"
.Size = 10
End With
With Selection.Borders
.LineStyle = xlContinuous
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
MsgBox (Format(Timer - t, "0.00000s"))
End Sub

复制代码

corient · 发表于 2015-11-14 23:25

神隐汀渚发表于 2015-11-14 11:13
才学的可能比较慢

非常感谢神隐汀渚大侠你的帮助，受益匪浅。能否再请教一个问题：是否可以让E列筛选后不显示出来？

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

[已解决]需要做一个简单的筛选功能

相关帖子

评分