可能发错版块了，请管理帮忙删除！！！

supper_idol · 发表于 2024-8-19 21:26

本帖最后由 supper_idol 于 2024-8-20 18:52 编辑

主要想要这个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, 下载次数: 8)

Excel_muke · 发表于 2024-8-20 18:43

这段试试符不符合你的需求，注意"Sheet1"表F2单元格需要用文本格式，不然直接取到日期格式的"/"符号来命名文件会报错。

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
Dim filledCount 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
name = Trim(name)
If name <> "" And Not dictExclusions.Exists(name) Then
dictExclusions.Add name, True
End If
Next name
End If
Next exclusionCell
' 从源数据中提取不重复的姓名
For Each cell In sourceRange
If cell.Value <> "" And Not dictExclusions.Exists(cell.Value) And Not dictNames.Exists(cell.Value) Then
dictNames.Add cell.Value, True
End If
Next cell
' 将不重复的姓名列表转换为数组
namesArray = dictNames.Keys()
' 初始化当前姓名索引
currentNameIndex = LBound(namesArray)
filledCount = 0
' 按列遍历目标范围 "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
' 找到不在排除列表中的姓名并填充
If currentNameIndex <= UBound(namesArray) Then
.Value = namesArray(currentNameIndex)
currentNameIndex = currentNameIndex + 1 ' 准备填充下一个空单元格
filledCount = filledCount + 1
End If
End If
End With
Next row
Next col
' 提示填充结果
MsgBox "填充完成，共填充了 " & filledCount & " 个姓名。"
' 检查F2单元格是否包含文本
If Not IsEmpty(destWs.Range("F2").Value) Then
' 定义新工作表的名称
Dim newSheetName As String
newSheetName = destWs.Range("F2").Value
' 验证新工作表名称是否有效
newSheetName = Application.WorksheetFunction.Clean(newSheetName)
newSheetName = Left(newSheetName, 31) ' 限制名称长度为31个字符
' 如果名称为空或包含无效字符，则给出错误提示
If newSheetName = "" Then
MsgBox "F2 单元格的名称无效，请确保名称不为空且不包含无效字符。"
Exit Sub
End If
' 保存当前工作表为新的文件
Dim newWorkbook As Workbook
Set newWorkbook = Workbooks.Add
destWs.Copy Before:=newWorkbook.Sheets(1)
newWorkbook.Sheets(1).Name = newSheetName
' 保存新工作簿
Dim filePath As String
filePath = ThisWorkbook.Path & "" & newSheetName & ".xlsx"
newWorkbook.SaveAs filePath
newWorkbook.Close
' 显示消息框，告知用户新工作簿已保存
MsgBox "新工作簿 '" & newSheetName & "' 已保存到：" & filePath
Else
MsgBox "F2 单元格为空，未保存新工作簿。"
End If
' 清理
Set sourceWs = Nothing
Set destWs = Nothing
Set sourceRange = Nothing
Set exclusionRange = Nothing
Set dictNames = Nothing
Set dictExclusions = Nothing
End Sub

复制代码

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

[求助] 可能发错版块了，请管理帮忙删除！！！

评分