VBA单元格事件

peter199083

第一次在论坛上解答问题，希望附件能对楼主有帮助。

1. Private Sub Worksheet_Activate()
   
2.     Call df
   
3. End Sub
   
4. 
   
5. Private Sub Worksheet_Change(ByVal Target As Range)
   
6.     If Target.Address = "$I$1" Then
   
7.         Call ff
   
8.     End If
   
9. End Sub
   
10. 
    
11. Sub df()
    
12.     Dim arr As Variant
    
13.     arr = Worksheets("Sheet1").[A1].CurrentRegion
    
14.    
    
15.     Set d_tle = CreateObject("scripting.dictionary")
    
16.     Dim i As Integer
    
17.     For i = 1 To UBound(arr, 2)
    
18.         d_tle(arr(1, i)) = i
    
19.     Next
    
20.    
    
21.     Set d_code = CreateObject("scripting.dictionary")
    
22.     For i = 2 To UBound(arr, 1)
    
23.         d_code(arr(i, d_tle("代码"))) = ""
    
24.     Next
    
25.    
    
26.     Dim list_code As String
    
27.     For Each Key In d_code.Keys
    
28.         If Not list_code = "" Then
    
29.         list_code = list_code & "," & Key
    
30.         Else
    
31.         list_code = Key
    
32.         End If
    
33.     Next
    
34.    
    
35.     Worksheets("Sheet2").[I1].Validation.Delete
    
36.     Worksheets("Sheet2").[I1].Validation.Add Type:=xlValidateList, Formula1:=list_code
    
37. End Sub
    
38. 
    
39. 
    
40. Sub ff()
    
41.     Dim arr As Variant
    
42.     arr = Worksheets("Sheet1").[A1].CurrentRegion
    
43.    
    
44.     Set d_tle = CreateObject("scripting.dictionary")
    
45.     Dim i As Integer
    
46.     For i = 1 To UBound(arr, 2)
    
47.         d_tle(arr(1, i)) = i
    
48.     Next
    
49.    
    
50.     Set d_code = CreateObject("scripting.dictionary")
    
51.     For i = 2 To UBound(arr, 1)
    
52.         d_code(arr(i, d_tle("代码"))) = ""
    
53.     Next
    
54.    
    
55.     Dim brr As Variant
    
56.     Dim row_arr, col_arr As Variant
    
57.     Dim r, c As Integer
    
58.     r = 0
    
59.     ReDim row_arr(1)
    
60.     For i = 1 To UBound(arr, 1)
    
61.         If arr(i, d_tle("代码")) = Worksheets("Sheet2").[I1].Value Then
    
62.             r = r + 1
    
63.             ReDim Preserve row_arr(r)
    
64.             row_arr(r) = i
    
65.         End If
    
66.     Next
    
67.     c = 0
    
68.     ReDim col_arr(1)
    
69.     For i = 1 To Worksheets("Sheet2").[A2].CurrentRegion.Columns.Count
    
70.         If d_tle.Exists(Worksheets("Sheet2").Cells(2, i).Value) = True Then
    
71.             c = c + 1
    
72.             ReDim Preserve col_arr(c)
    
73.             col_arr(c) = d_tle(Worksheets("Sheet2").Cells(2, i).Value)
    
74.         End If
    
75.     Next
    
76.    
    
77.     Dim crr As Variant
    
78.     ReDim crr(1 To UBound(row_arr), 1 To UBound(col_arr))
    
79.     For i = 1 To UBound(row_arr)
    
80.         For j = 1 To UBound(col_arr)
    
81.            crr(i, j) = arr(row_arr(i), col_arr(j))
    
82.         Next
    
83.     Next
    
84.    
    
85.     Worksheets("Sheet2").[A1].Offset(2).Resize(UBound(crr, 1), UBound(crr, 2)) = crr
    
86. End Sub

复制代码

yumz@123

peter199083 发表于 2023-3-29 14:00
第一次在论坛上解答问题，希望附件能对楼主有帮助。

谢谢，感谢你的回答