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

supper_idol · 发表于 2024-8-20 18:51

主要想要这个VBA宏代码实现：从一个名为"所有人员名单"的源工作表中提取不重复的姓名，并将它们填充到另一个名为"Sheet1"的目标工作表中，它通过排除已存在的姓名，将新的不重复的姓名填充到目标工作表中，以避免重复和遗漏。并用F2的值在excel簿中另存这张表。

以下是部分需求：
设置源和目标工作表：将"所有人员名单"设置为源工作表，"Sheet1"设置为目标工作表。
定义源数据和排除数据的范围：源数据范围是源工作表的A1到A58单元格，排除数据范围是目标工作表的C24到C40单元格。
提取排除姓名：排除范围中的每个单元格，按"、"分隔符分割姓名，并将它们添加到排除字典中。（同名的问题没想到怎么解决）
消息框提示：显示一个消息框，告知用户填充完成，并显示填充了多少个姓名。并另存为新表完毕（未完成）。

以下VBA函数是我结合Kimi折腾出来的，虽然能完成数据的填充，但是运行会提示下标越界。

Sub FillSheet1ColumnByColumnWithExclusionCriteria()
' 声明变量
Dim sourceWs As Worksheet
Dim destWs As Worksheet
Dim sourceRange As Range
Dim exclusionRange As Range
Dim cell As Range
Dim exclusionCell As Range
Dim dictNames As Object
Dim dictExclusions As Object
Dim namesArray() As Variant
Dim currentNameIndex As Long
Dim col As Integer
Dim row As Long
' 设置源工作表和目标工作表
Set sourceWs = ThisWorkbook.Sheets("所有人员名单") ' 源数据工作表
Set destWs = ThisWorkbook.Sheets("Sheet1") ' 目标工作表
' 创建字典对象来存储不重复的姓名和排除的姓名列表
Set dictNames = CreateObject("Scripting.Dictionary")
Set dictExclusions = CreateObject("Scripting.Dictionary")
' 定义源数据的范围和排除数据的范围
Set sourceRange = sourceWs.Range("A1:A58")
Set exclusionRange = destWs.Range("C24:C40")
' 从排除范围中提取姓名并存储在字典中
For Each exclusionCell In exclusionRange
If Not IsEmpty(exclusionCell.Value) Then
Dim exclusionNames As Variant
exclusionNames = Split(exclusionCell.Value, "、") ' 确保使用正确的分隔符
Dim name As Variant
For Each name In exclusionNames
If Trim(name) <> "" Then
dictExclusions.Add Trim(name), True ' 使用Add而不是Exists
End If
Next name
End If
Next exclusionCell
' 从源数据中提取不重复的姓名
For Each cell In sourceRange
If cell.Value <> "" Then
dictNames(cell.Value) = True
End If
Next cell
' 将不重复的姓名列表转换为数组
namesArray = dictNames.Keys()
' 初始化当前姓名索引
currentNameIndex = LBound(namesArray)
' 按列遍历目标范围 "A4:F23"
For col = 1 To destWs.Range("A4:F23").Columns.Count
' 遍历目标列的每一行
For row = 4 To 23
With destWs.Cells(row, col)
If IsEmpty(.Value) Then
' 找到不在排除列表中的姓名并填充
While currentNameIndex <= UBound(namesArray) And _
dictExclusions.Exists(namesArray(currentNameIndex))
currentNameIndex = currentNameIndex + 1
Wend
If currentNameIndex <= UBound(namesArray) Then
.Value = namesArray(currentNameIndex)
currentNameIndex = currentNameIndex + 1 ' 准备填充下一个空单元格
End If
End If
End With
Next row
Next col
' 清理
Set sourceWs = Nothing
Set destWs = Nothing
Set sourceRange = Nothing
Set exclusionRange = Nothing
Set dictNames = Nothing
Set dictExclusions = Nothing
MsgBox "填充完成，共填充了 " & (currentNameIndex - LBound(namesArray)) & " 个姓名。"
' 检查F2单元格是否包含文本
If Not IsEmpty(destWs.Range("F2").Value) Then
' 定义新工作表的名称
Dim newSheetName As String
newSheetName = destWs.Range("F2").Value
' 创建一个新的工作表并命名
Dim newWs As Worksheet
Set newWs = ThisWorkbook.Worksheets.Add
newWs.Name = newSheetName
' 复制源工作表的内容到新工作表
destWs.Cells.Copy newWs.Cells
' 可选：删除源工作表
' destWs.Delete
' 显示消息框，告知用户新工作表已创建
MsgBox "新工作表 '" & newSheetName & "' 已创建。"
Else
MsgBox "F2 单元格为空，无法创建新工作表。"
End If
End Sub

复制代码

求大佬帮忙！！！！

点名册.rar (18.12 KB, 下载次数: 9)

ykcbf1100 · 发表于 2024-8-22 19:53

另存新表。。。

Sub ykcbf() '//2024.8.22 另存新表
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
brr = .[c24:c28].Value
fn = Format(.[f2].Value, "m月d日")
For Each k In brr
If k <> Empty Then
st = st & "、" & k
End If
Next
brr = Split(Mid(st, 2), "、")
For Each k In brr
d1(k) = ""
Next
End With
With Sheets("所有人员名单")
r = .Cells(Rows.Count, 1).End(3).row
arr = .[a1].Resize(r, 1)
For i = 1 To UBound(arr)
s = arr(i, 1)
If Not d1.exists(s) Then d(s) = ""
Next
End With
With Sheets("Sheet1")
m = 3: n = 2
For Each k In d.keys
m = m + 1
.Cells(m, n) = k
If m = 23 Then m = 3: n = n + 2
Next
End With
On Error Resume Next
Set sht = Worksheets(fn)
Sheets("Sheet1").Cells.Copy sht.[a1]
sht.DrawingObjects.Delete
If Err.Number <> 0 Then
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
Set sht = Sheets(Sheets.Count)
sht.name = fn
sht.DrawingObjects.Delete
End If
Set d = Nothing
Set d1 = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-8-20 19:52

附件供参考。。。

ykcbf1100 · 发表于 2024-8-20 19:52

代码供参考。。。

gwjkkkkk · 发表于 2024-8-20 20:20

本帖最后由 gwjkkkkk 于 2024-8-20 20:29 编辑

Option Explicit
Sub TEST6()
Dim ar, br, i&, j&, n&, iPosCol&, dic As Object, strFileName$

With Worksheets(1).[F2]
      If .Value = Empty Then MsgBox "时间为空", vbCritical: Exit Sub
      strFileName = Format(.Value, "yyyy年m月d")
End With

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dic = CreateObject("Scripting.Dictionary")

ar = Worksheets("所有人员名单").[A1].CurrentRegion.Value
For i = 2 To UBound(ar)
      dic(ar(i, 1)) = Empty
Next i
ar = Worksheets(1).[C24:C28].Value
For i = 1 To UBound(ar)
      br = Split(ar(i, 1), "、")
      For j = 0 To UBound(br)
         If dic.exists(br(j)) Then dic.Remove br(j)
      Next j
Next i

ar = dic.keys: n = dic.Count
ar = transArrToCol(ar, 20, 0, UBound(ar))

Worksheets(1).Copy
With ActiveWorkbook
      With .Worksheets(1)
         ReDim br(1 To UBound(ar), 0)
         For j = 1 To UBound(ar, 2)
            iPosCol = j * 2
            For i = 1 To UBound(ar)
                  br(i, 0) = ar(i, j)
            Next i
            .Cells(4, iPosCol).Resize(20) = br
         Next j
      End With
      .SaveAs ThisWorkbook.Path & "\" & strFileName
      .Close
End With

Set dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "共填充" & n & "个姓名", vbInformation
Beep
End Sub

Function transArrToCol(ByVal ar, ByVal iCutNum&, _
ByVal iStartCol&, ByVal iEndCol&) As Variant()
Dim br, j&, n&, y&, x&, iRowSize&

If iStartCol < LBound(ar) Then iStartCol = LBound(ar)
If iEndCol > UBound(ar) Then iEndCol = UBound(ar)

n = -(Int(-(iEndCol - iStartCol + 1) / iCutNum))
iRowSize = IIf(iEndCol - iStartCol + 1 < iCutNum, iEndCol - iStartCol + 1, iCutNum)
ReDim br(1 To iRowSize, 1 To n)

n = 0
For j = iStartCol To iEndCol
      n = n + 1
      x = -Int(-n / iCutNum)
      y = IIf(n Mod iCutNum = 0, iCutNum, n Mod iCutNum)
      br(y, x) = ar(j)
Next j
transArrToCol = br
End Function

gwjkkkkk · 发表于 2024-8-20 20:21

本帖最后由 gwjkkkkk 于 2024-8-20 20:28 编辑

请参考附件。。。

supper_idol · 发表于 2024-8-20 22:06

ykcbf1100 发表于 2024-8-20 19:52
附件供参考。。。

确实填充了，但是没有排除指定区域出现的人员，还有没有另存为新的表

supper_idol · 发表于 2024-8-20 22:08

gwjkkkkk 发表于 2024-8-20 20:21
请参考附件。。。

在当前excel簿中，另存一张sheet表（用F2区域的时间命名）就更完美了

ykcbf1100 · 发表于 2024-8-21 07:08

supper_idol 发表于 2024-8-20 22:06
确实填充了，但是没有排除指定区域出现的人员，还有没有另存为新的表

改好了。。。

ykcbf1100 · 发表于 2024-8-21 07:08

改一下。。。

Sub ykcbf() '//2024.8.21
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
brr = .[c24:c28].Value
For Each k In brr
If k <> Empty Then
st = st & "、" & k
End If
Next
brr = Split(Mid(st, 2), "、")
For Each k In brr
d1(k) = ""
Next
End With
With Sheets("所有人员名单")
r = .Cells(Rows.Count, 1).End(3).row
arr = .[a1].Resize(r, 1)
For i = 1 To UBound(arr)
s = arr(i, 1)
If Not d1.exists(s) Then d(s) = ""
Next
End With
With Sheets("Sheet1")
m = 3: n = 2
For Each k In d.keys
m = m + 1
.Cells(m, n) = k
If m = 23 Then m = 3: n = n + 2
Next
End With
Sheets("Sheet1").Copy
Set wb = ActiveWorkbook
wb.Sheets(1).DrawingObjects.Delete
wb.SaveAs ThisWorkbook.Path & "\人员点名册"
wb.Close
Set d = Nothing
Set d1 = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

supper_idol · 发表于 2024-8-22 19:30

ykcbf1100 发表于 2024-8-21 07:08
改好了。。。

厉害厉害！
但是，老师，另存新表不是在同一个簿里面，而是生成了新的簿，也不是用的F2区域的文字命名的。

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

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

评分

评分

评分

评分