|
|
楼主 |
发表于 2018-10-5 16:43
|
显示全部楼层
老师：把代码复制进对应的位置后，复制指定条件和按钮到第六个工作表的C1:F8。数据源《组三》的指定条件在I列，数据区域在T列。一.代码需要复制进 【类1(代码)】里；Public WithEvents myApp As Application
Private Sub myApp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Address = "$F$4" Then Call pp
If Target.Address = "$E$1" Then Call auto_open
If Target.Address = "$E$2" Then Call auto_open
If Target.Address = "$E$3" Then Call auto_open
If Target.Address = "$E$4" Then Call auto_open
If Target.Address = "$E$5" Then Call auto_open
End Sub
二.以下代码，则需要复制粘贴进【模块1】里。
Dim myAppCls As New 类1
Sub InitializeAppEvent()
Set myAppCls.myApp = Application
End Sub
Sub qq()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
ws.Range("f4") = ws.Shapes("myDropDown").ControlFormat.List( _
ws.Shapes("myDropDown").ControlFormat.Value)
End Sub
Sub pp()
Dim i, j, k, x, y, ar, br, cr, dr, mysh 'As Worksheet
ar = Range("e1:e8"): x = Cells(4, "f"): j = Cells(1, "f")
If ar(1, 1) = "" Then mysh = ActiveSheet.Name Else mysh = ar(1, 1).Name
br = Range(Sheets("" & mysh & "").Cells(ar(4, 1), ar(2, 1)), Sheets("" & mysh & "").Cells(ar(5, 1), ar(2, 1)))
cr = Range(Sheets("" & mysh & "").Cells(ar(4, 1), ar(3, 1)), Sheets("" & mysh & "").Cells(ar(5, 1), ar(3, 1)))
For k = UBound(br) To 1 Step -1
If br(k, 1) <> "" Then Exit For
Next
ReDim dr(1 To k, 0)
For i = 1 To k
If br(i, 1) <> "" And cr(i, 1) <> "" And br(i, 1) = x Then
y = y + 1: dr(y, 0) = cr(i, 1)
End If
Next
For i = 1 To k
If i > y Then dr(i, 0) = ""
Next
Cells(5, j).Resize(ar(8, 1) - 4) = ""
Cells(ar(7, 1), ar(6, 1)).Resize(ar(8, 1) - 4) = dr
Cells(1, "f") = ar(6, 1)
End Sub
Sub auto_open()
Dim i, k, ar, br, cr, myShap As ControlFormat, ws As Worksheet
Dim h As New Collection, myObj As Object, myshape As Shape, mysh
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(1)
ar = Range("e1:e8")
If ar(1, 1) = "" Then mysh = ActiveSheet.Name Else mysh = ar(1, 1).Name
br = Range(Sheets("" & mysh & "").Cells(ar(4, 1), ar(2, 1)), Sheets("" & mysh & "").Cells(ar(5, 1), ar(2, 1)))
For k = UBound(br) To 1 Step -1
If br(k, 1) <> "" Then Exit For
Next
For i = 1 To k
If br(i, 1) <> "" Then h.Add br(i, 1), CStr(br(i, 1))
Next
ReDim cr(1 To h.Count): ReDim myArray(1 To h.Count)
For i = 1 To h.Count: cr(i) = h(i): Next
For i = 1 To h.Count: myArray(i) = CStr(Application.Small(cr, i)): Next
ws.Shapes("myDropDown").Delete
ws.Shapes.AddFormControl(xlDropDown, 250, 1, 30, 30).Name = "myDropDown"
Set myShap = ws.Shapes("myDropDown").ControlFormat
Set myObj = myShap: myObj.List = myArray
Set myshape = ws.Shapes("myDropDown")
myshape.OnAction = "qq"
Call InitializeAppEvent
End Sub
但是为什么点开按钮，里面的指定条件没有随之变化，仍是11~20【应该是组三!I列的112~566，共计30个不重复条件】；点击按钮后找不到指定条件，出现错误；点击按钮里面的随便数字，跳出“运行时错误‘1004’警告，单击调试，有问题的黄色填充代码显示如下：
ws.Range("f4") = ws.Shapes("myDropDown").ControlFormat.List( _
ws.Shapes("myDropDown").ControlFormat.Value)
Video_20181005163345.zip
(466.83 KB, 下载次数: 3)
指定宏不能运行。
|
|
楼主: WYS67
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-9-29 15:34