Question

我开始了解Excel VBA。我有一个工作程序，在一个工作表上使用一个操作按钮打开一个源工作簿和数据工作表，选择数据并将其放入第二个工作簿和目标表。然后我根据需要对数据进行排序，看起来像这样 Destination sheet, sorted and annotated duplicates

我现在正在尝试根据第2栏＆＃34; B＆＃34;选择数据。如果项目重复和/或没有重复，则执行操作（向管理员发送有关其控制下的工作人员的电子邮件）。我可以收到一封电子邮件，但它会选择我遇到问题的数据。

输出数据为col 1＆amp;第3栏至第5栏，例如

亲爱的经理1，

您下面列出的工作人员已达到xyz

Person1 22/06/2017 11/08/2017 22/08/2017
Person11 22/06/2017 11/08/2017 22/08/2017
Person15 22/06/2017 11/08/2017 22/08/2017

...祝贺

所以我希望有人可以帮助我，这是一个线索，我将如何看待第2栏中的数据添加数组所需的Row数据或其他东西然后检查下一行将它添加到同一个东西，直到它与下一行不同为止暂停执行下一次迭代。导致：

经理1 .....人1,11,15
行动
经理10 .....人10
行动
经理2 .....人12,16,2,25,28
行动
经理3 .....人13,17,26,29,3
行动

直到达到最后一行。

我对数组/查找和循环感到困惑，我在途中遗失了一些情节我有一个变量 lastTmp ，它告诉我集合中的最后一行数据，每个月都会有所不同。
范围是：
Set rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).row)
我工作代码的最后一部分是：

Dim lp As Integer
lp = 1
For Each cell In rng1
    If 1 < Application.CountIf(rng1, cell.Value) Then
        With cell
                .Offset(0, 4) = "duplicate : "
                .Offset(0, 5) = lp
                End With
                Else
                With cell
                .Offset(0, 4) = "NOT duplicate : "
                .Offset(0, 5) = 0
                End With
        End If
    Next cell

Answer 1

如果你更有逻辑地进行缩进，你将能够更好地面对混乱。相关的For / Next，If / Else / End If和With / End With应始终位于相同的缩进级别，以便于阅读。我重新安排了你原来的代码： -

For Each Cell In Rng1
    If 1 < Application.CountIf(Rng1, Cell.Value) Then
        With Cell
            .Offset(0, 4) = "duplicate : "
            .Offset(0, 5) = lp
        End With
    Else
        With Cell
            .Offset(0, 4) = "NOT duplicate : "
            .Offset(0, 5) = 0
        End With
    End If
Next Cell

现在很明显With Cell / End With不需要重复。我进一步假设您的变量lp实际上是为了保持计数。这使我得到了以下代码压缩。

Dim Rng1 As Range
Dim Cell As Range
Dim lp As Integer

' the sheet isn't specified: uses the ActiveSheet
Set Rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)

For Each Cell In Rng1
    With Cell
        lp = Application.CountIf(Rng1, .Value)
        .Offset(0, 4) = IIf(lp, "", "NOT ") & "duplicate : "
        .Offset(0, 5) = lp
    End With
Next Cell

Answer 2

每当检查重复项时，请考虑使用词典或集合。

在这里，我使用字典词典来编译管理员的人员列表。

Sub ListManagerList1()
    Dim cell As Range
    Dim manager As String, person As String
    Dim key As Variant

    Dim dictManagers As Object
    Set dictManagers = CreateObject("Scripting.Dictionary")

    For Each cell In Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        manager = cell.Value
        person = cell.Offset(0, -1).Value

        If Not dictManagers.Exists(manager) Then
            dictManagers.Add manager, CreateObject("Scripting.Dictionary")
        End If

        If Not dictManagers(manager).Exists(person) Then
            dictManagers(manager).Add person, vbNullString
        End If
    Next

    For Each key In dictManagers
        Debug.Print key & " -> "; Join(dictManagers(key).Keys(), ",")
    Next

End Sub

我建议你想要Excel VBA Introduction Part 39 - Dictionaries

Answer 3

假设您的数据与图像一样

然后下面的代码将给出结果，如下图所示。

Sub Demo()
    Dim srcSht As Worksheet, destSht As Worksheet
    Dim lastRow As Long, i As Long
    Dim arr1(), arr2()
    Dim dict As Object

    Set dict = CreateObject("scripting.dictionary")
    Set srcSht = ThisWorkbook.Sheets("Sheet2")  'change Sheet2 to your data sheet
    Set destSht = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your output sheet

    arr1 = Application.Index(srcSht.Cells, [row(1:7000)], Array(2, 1))  'See note below
    arr2 = arr1

    For i = 1 To UBound(arr1, 1)
        If Not dict.exists(LCase$(arr1(i, 1))) Then
            dict.Add LCase$(arr1(i, 1)), i
        Else
            arr2(i, 1) = vbNullString
            arr2(dict.Item(LCase$(arr1(i, 1))), 2) = arr2(dict.Item(LCase$(arr1(i, 1))), 2) & "," & arr1(i, 2)
        End If
    Next
    destSht.Range("A1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr2 'display result
    destSht.Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
End Sub

注意： 有关为数组指定范围的详细信息，请参阅this。

迭代行范围组数据并采取措施

行动

行动

行动

行动

3 个答案: