想做一个动态人员花名册，遇到了一点问题，求大神帮助指导

ykcbf1100

supper_idol 发表于 2024-8-22 19:30
厉害厉害！
但是，老师，另存新表不是在同一个簿里面，而是生成了新的簿，也不是用的F2区域的文字命名的 ...

对题意理解不透。

再改一次吧。

ykcbf1100

另存新表。。。

1. Sub ykcbf()  '//2024.8.22   另存新表
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("Sheet1")
   
6.         brr = .[c24:c28].Value
   
7.         fn = Format(.[f2].Value, "m月d日")
   
8.         For Each k In brr
   
9.             If k <> Empty Then
   
10.                 st = st & "、" & k
    
11.             End If
    
12.         Next
    
13.         brr = Split(Mid(st, 2), "、")
    
14.         For Each k In brr
    
15.             d1(k) = ""
    
16.         Next
    
17.     End With
    
18.     With Sheets("所有人员名单")
    
19.         r = .Cells(Rows.Count, 1).End(3).row
    
20.         arr = .[a1].Resize(r, 1)
    
21.         For i = 1 To UBound(arr)
    
22.             s = arr(i, 1)
    
23.             If Not d1.exists(s) Then d(s) = ""
    
24.         Next
    
25.     End With
    
26.     With Sheets("Sheet1")
    
27.         m = 3: n = 2
    
28.         For Each k In d.keys
    
29.             m = m + 1
    
30.             .Cells(m, n) = k
    
31.             If m = 23 Then m = 3: n = n + 2
    
32.         Next
    
33.     End With
    
34.     On Error Resume Next
    
35.     Set sht = Worksheets(fn)
    
36.     Sheets("Sheet1").Cells.Copy sht.[a1]
    
37.     sht.DrawingObjects.Delete
    
38.     If Err.Number <> 0 Then
    
39.         Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
    
40.         Set sht = Sheets(Sheets.Count)
    
41.         sht.name = fn
    
42.         sht.DrawingObjects.Delete
    
43.     End If
    
44.     Set d = Nothing
    
45.     Set d1 = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "OK！"
    
48. End Sub
    

复制代码

Qs18

Sub qs()
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    Dim arr, i, dic, xb As Workbook
    Set dic = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    arr = Sheet2.Range("a1").CurrentRegion.Value
    brr = Sheet1.[c24:c40].Value
    For Each b In brr
        If Len(b) > 0 Then
            s = s & "、" & b
        End If
    Next
    sr = Split(s, "、")
    For Each srr In sr
        d2(srr) = srr
    Next
    For i = 1 To UBound(arr)
        ss = arr(i, 1)
        
        If Not d2.exists(ss) Then
            dic(ss) = ss
        End If
    Next
    ReDim crr(1 To 20, 1 To 3)
    cl = 1
    For Each k In dic.keys
        m = m + 1
        If m > 20 Then
            m = 1
            cl = cl + 1
            crr(m, cl) = k
        Else
            crr(m, cl) = k
        End If
    Next
    For cc = 2 To 6 Step 2
        x = x + 1
        Sheet1.Cells(4, cc).Resize(UBound(crr), 1) = Application.Index(crr, 0, x)
    Next
    MsgBox "填充完成，共填充了 " & dic.Count & " 个姓名。"
    t = Format([f2].Value, "yyyy年mm月dd日"): p = ThisWorkbook.Path & "\"
    Sheet1.Copy
    Set xb = ActiveWorkbook
    xb.SaveAs p & t & ".xlsx"
    xb.Close
    MsgBox "另存为新的工作簿完毕！路径为：" & p & t & ".xlsx"
    Set dic = Nothing: Set d2 = Nothing
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub

Qs18

试试.................

Qs18

试试...........

supper_idol

ykcbf1100 发表于 2024-8-22 19:53
另存新表。。。

nice 完美！！！！已在附件回复送了小花花

supper_idol

Qs18 发表于 2024-8-22 21:07
Sub qs()
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    Dim arr, i, ...

感谢感谢！ 向您学习。