无重复数据录入模板

Posted 2023-03-29

【中文标题】无重复数据录入模板

【英文标题】：Data entry temlplate without duplicate

【发布时间】：2019-05-31 22:53:24

【问题描述】：

我不是专家，但需要帮助...作为我项目的一部分，我正在开发一个用于数据输入的 Excel 宏。

我在 sheet1（数据输入表单）中输入的任何数据都应保存在 sheet2 中。 每当我在 sheet2 中输入现有员工 ID 时，我需要弹出带有 msg“可用数据”的窗口，并应反映在相应的列中 每当我为上述情况输入数据时“数据已存在于 sheet2 中），尽管信息相同，但剩余值应保存在表 2 中的相同标题下，方法是通过逗号分隔添加到现有信息中。 不应为相同的员工 ID 创建重复记录，除非将信息添加到现有记录中

我试过的 Excel VBA 宏

通过在 sheet1 中输入信息，我需要在 sheet2 中的以下详细信息

输入票号 输入员工编号 选择看门人 将票分配给（1 级） 一级 Val 状态 将票分配给（第 2 级） 二级验证状态 QA 检查完成者 已发送详细备注 备注

代码：

Private Sub CommandButton1_Click()
Dim TicketID As String, Dat As Date, Clientname As String
Dim EmpID As Double, Gatekeep As String, fisrtlevelname As String
Dim firstlevelStatus As String, secondlevelname As String, Secondlevelstatus As String, QA As String, Remarks As String
Worksheets("Sheet1").Select
TicketID = Range("B2")
Dat = Range("B3")
Clientname = Range("B4")
EmpID = Range("B5")
Gatekeep = Range("B6")
fisrtlevelname = Range("B7")
firstlevelStatus = Range("B8")
secondlevelname = Range("B9")
Secondlevelstatus = Range("B10")
QA = Range("B11")
Remarks = Range("B12")
Worksheets("Sheet2").Select
Worksheets("Sheet2").Range("A1").Select
If Worksheets("Sheet2").Range("A1").Offset(1, 0) <> "" Then
Worksheets("Sheet2").Range("A1").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = TicketID
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Dat
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Clientname
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = EmpID
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Gatekeep
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = fisrtlevelname
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = firstlevelStatus
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = secondlevelname
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Secondlevelstatus
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = QA
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Remarks
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range("B2").Select
End Sub

【问题讨论】：

我在下面使用的代码

为什么不直接复制 sheet1 中的 B2:B12 范围并粘贴到 sheet2 中的下一个空行。看到这个SO Question的答案@

我用于数据输入的第一张表...我认为 B2:B12 是代理可以输入数据的字段。在点击更新时，它应该保存在 sheet2 A2: J2 中。同样，每个条目都会进行此活动。但需要识别现有记录并将数据附加到已创建的行项目中，没有任何重复条目

【参考方案1】：

要尝试的新代码：假设员工 ID 需要覆盖输入的其余部分，仅与现有数据进行比较。

Sub TryThis()
Dim Data As Variant
'Loads your data into an array beginning at (1,1) and ending at (11,1)
Worksheets("Sheet1").Activate
Data = Range("B2", "B12")
'Selects worksheet 2 and puts in your data. I personally don't like the .activate, but for a simple program
'that this seems to be, it shouldn't hurt your performance.
Worksheets("Sheet2").Activate
    'evaluates if it is the first entry by determing if cell is empty
    If Range("A2") <> "" Then
        'If it is not empty, sheet2 is put into an array (an array is overkill unless you have a lot of data)
        Dim Comp As Variant
        Comp = Range("A2", Range("A1").End(xlDown).End(xlToRight))
        'looks at each employee ID already existing in sheet2
        For i = 1 To UBound(Comp)
            'If the employee Id exists, it will write over it here.
            If Data(4, 1) = Comp(i, 4) Then
                MsgBox "Employee ID Exists" & vbNewLine & "Employee Information Updated"
                Dim CCount As Long
                CCount = 1
                Do Until CCount = 11
                    'used i + 1 because of your header on sheet2 and was too lazy to create a new variable
                    Cells(i + 1, CCount).Value = Data(CCount, 1)
                    CCount = CCount + 1
                Loop
            Worksheets("Sheet1").Activate
            'Resets your input range
            Range("B2:B17").Value = ""
            'Since the information is written here, it will exit sub for next entry
            Exit Sub
            End If
        Next i
    End If

        Dim RCount As Long
        RCount = 2
        Do Until Cells(RCount, 2) = ""
            RCount = RCount + 1
        Loop

        CCount = 1
        Do Until CCount = 11
            Cells(RCount, CCount).Value = Data(CCount, 1)
            CCount = CCount + 1
        Loop
        MsgBox "New Employee Id" & vbNewLine & "New Information Added"
        Worksheets("Sheet1").Activate
        Range("B2:B12").Value = ""
End Sub    

给出的原始代码

Sub TryThis()
Dim Data As Variant
'Loads your data into an array beginning at (1,1) and ending at (11,1)
Worksheets("Sheet1").Activate
    Data = Range("B2", "B18")

'Selects worksheet 2 and puts in your data. I personally don't like the .activate, but for a simple 
'program that this seems to be, it shouldn't hurt your performance.
Worksheets("Sheet2").Activate
    Dim RCount As Long
    RCount = 2
        Do Until Cells(RCount, 2) = ""
        RCount = RCount + 1
        Loop
    Dim CCount As Long
    CCount = 1
        Do Until CCount = 17
            Cells(RCount, CCount).Value = Data(CCount, 1)
            CCount = CCount + 1
        Loop
End Sub

【讨论】：

出于复制的目的，我们可以使用来自sheet1 的数据数组循环遍历sheet2 中的值。但是，为了提高效率，不是查看所有 17 条数据，是否有一些如果它们相等，则其他所有数据都相等？我使用了一个类似的循环，它有 40 条数据，但如果有 2 条相同，则其余的将相同，这使得比较和逻辑更容易理解。

我用于数据输入的第一张表...我认为 B2:B12 是代理可以输入数据的字段。在点击更新时，它应该保存在 sheet2 A2: J2 中。同样，每个条目都会进行此活动。但需要识别现有记录并将数据附加到已创建的行项目中，没有任何重复条目

你能帮帮我吗..有点急

您似乎想追加数据，但有一个写入。本质上，你在看if EmployeeId Exists Then Overwrite that line吗？

更新代码供您尝试。唯一的比较是员工 ID。如果需要更多比较，则只需添加 and 和 comparison。