条件提取数据在同一工作表内。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.11
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     For Each sht In Sheets
   
7.         If sht.Name = "打印" Then sht.Delete
   
8.     Next
   
9.     Sheets.Add(After:=Sheets(Sheets.Count)).Name = "打印"
   
10.     arr = Sheets("字典").UsedRange
    
11.     For i = 2 To UBound(arr)
    
12.         s = arr(i, 1)
    
13.         d1(s) = arr(i, 2)
    
14.     Next
    
15.     With Sheets("名单")
    
16.         r = .Cells(Rows.Count, 1).End(3).Row
    
17.         arr = .[a1].Resize(r, 4)
    
18.     End With
    
19.     For i = 2 To UBound(arr)
    
20.         s = arr(i, 2)
    
21.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
22.         d(s)(i) = ""
    
23.     Next
    
24.     With Sheets("打印")
    
25.         For Each k In d.keys
    
26.             n = n + 1
    
27.             m = 0
    
28.             ReDim brr(1 To d(k).Count, 1 To 2)
    
29.             If n = 1 Then
    
30.                 r = 1
    
31.                 Sheets("记录样表").Cells.Copy .Cells(r, 1)
    
32.             Else
    
33.                 r = .Cells(Rows.Count, 1).End(3).Row + 2
    
34.                 Sheets("记录样表").Rows("1:16").Copy .Cells(r, 1)
    
35.             End If
    
36.             For Each kk In d(k).keys
    
37.                 m = m + 1
    
38.                 brr(m, 1) = m
    
39.                 brr(m, 2) = arr(kk, 3)
    
40.             Next
    
41.             If m > 11 Then
    
42.                 For i = 1 To m - 11
    
43.                     .Cells(r + 5 + i, 1).EntireRow.Insert
    
44.                 Next i
    
45.             Else
    
46.                 .UsedRange.Offset(r + m + 4).Clear
    
47.             End If
    
48.             .Cells(r + 4, 1).Resize(m, 2) = brr
    
49.             .Cells(r + 1, 3) = k: .Cells(r + 1, "n") = d1(k)
    
50.         Next
    
51.     End With
    
52.     Sheets("名单").Activate
    
53.     Set d = Nothing
    
54.     Set d1 = Nothing
    
55.     Application.ScreenUpdating = True
    
56.     MsgBox "OK！"
    
57. End Sub
    
58. 
    

复制代码