使用Excel VBA构建二分之一的列表 [英] Build one list out of two with Excel VBA

问题描述

我正在构建一个应用程序，以首先将数据从一个工作簿复制到另一个工作簿(该工作簿已经在工作).

I am building an application to firstly copy data from one Workbook to another (this is working already).

然后是最不确定的部分，我不确定是否可能. 有两个数据列表.

Then comes the most complicated part that I am not sure yet if it is even possible. There are two lists of data.

第一个(Sheet1):

First one (Sheet1):

第二(Sheet2):

Second one (Sheet2):

代码应比较B和C列，并为(Sheet3)建立一个新列表，如下所示:

Code should compare columns B and C and build new list to (Sheet3) that will look like this:

因此，首先构建Sheet3，然后进行比较，如果发现重复，则将值添加到对应的(B列).如果找不到重复项，则用数据换行.

So first build Sheet3, after comparison, if duplicate has been found then add value to corresponding (column B). If duplicate not found, then make new line with data.

这是我的代码，用于检测重复项.

Here is my code to detect duplicates.

Sub CheckAvailability()
Dim rMyRng As Range, rCompare As Range, r As Range, lFound As Long, blStatus As Boolean

Application.ScreenUpdating = False

With Sheets("Sheet1")
    Set rMyRng = .Range("B2:C" & Range("C" & Rows.Count).End(xlUp).row)
End With

With Sheets("Sheet2")
    Set rCompare = .Range("B2:C" & Range("C" & Rows.Count).End(xlUp).row)
End With

For Each r In rMyRng.Rows
    With r
        .Select
        blStatus = False
        lFound = Application.CountIfs(rCompare.Columns(1), .Cells(1).Value, rCompare.Columns(2), .Cells(2).Value)
        If lFound Then blStatus = True
        .Cells(2).Offset(, 1).Value = blStatus
    End With
Next r

Application.ScreenUpdating = True

End Sub

使用我当前的代码，我将其作为输出，这是正确的.如何使其余的一切正常工作?

With my current code I get this as an output, that is correct. How to make all the rest working?

推荐答案

由于范围广泛，因此不确定这是否是最好的方法，但感觉就像尝试一些字典=).希望对您有所帮助.

Not sure if this is the best way as it's quite extensive, but felt like trying some dictionary =). Hopefully it's helpfull.

带有字典的数组(串联)

Arrays with Dictionary (concatenated)

• 使用两个列表中填充的两个数组
• 遍历第一个数组以将项目加载到字典中
• 遍历第二个数组以检查它们是否存在于字典中.如果是这样，请检查邮箱号码并采取相应措施
• 遍历字典以将其值转换为sheet3

Sub BuildList()

'Declare all the variables
Dim x As Long, arr1 As Variant, arr2 As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

'Fill 1st array from sheet1
With Sheet1
    x = .Cells(.Rows.Count, 3).End(xlUp).Row
    arr1 = .Range("A2:C" & x).Value
End With

'Fill 2nd array from sheet2
With Sheet2
    x = .Cells(.Rows.Count, 3).End(xlUp).Row
    arr2 = .Range("A2:C" & x).Value
End With

'Load 1st array into dictionary
For x = LBound(arr1) To UBound(arr1)
    dict.Add arr1(x, 2), arr1(x, 1) & "||" & arr1(x, 2) & "|" & arr1(x, 3)
Next x

'Load 2nd array into dictionary with test
For x = LBound(arr2) To UBound(arr2)
    If dict.Exists(arr2(x, 2)) Then
        If Trim(arr2(x, 3)) = Split(dict(arr2(x, 2)), "|")(3) Then
            dict(arr2(x, 2)) = Split(dict(arr2(x, 2)), "|")(0) & "|" & arr2(x, 1) & "|" & arr2(x, 2) & "|" & arr2(x, 3)
        Else
            dict.Add arr2(x, 2) & "x", "|" & arr2(x, 1) & "|" & arr2(x, 2) & "|" & arr2(x, 3)
        End If
    Else
        dict.Add arr2(x, 2), "|" & arr2(x, 1) & "|" & arr2(x, 2) & "|" & arr2(x, 3)
    End If
Next x

'Transpose dictionary into sheet3
With Sheet3
    x = 2
    For Each Key In dict.keys
        .Cells(x, 1).Resize(1, 4).Value = Split(dict(Key), "|")
        x = x + 1
    Next Key
End With

End Sub

---

带有字典的数组(类模块)

---

Arrays with Dictionary (class module)

根据我的评论，第二个选择是还包括一个类模块.只需添加以下类模块，名称为clssList:

A second option, as per my comment, is to also include a class module. Simply add the following class module, and name is clssList:

Public Number1 As Variant
Public Number2 As Variant
Public NameSpec As String
Public PostBox As Long

现在，我们可以通过该类模块设置新对象，并使用它们来填充字典:

Now instead of the previous code, we can set new objects through this classmodule and populate our dictionary with them:

Sub BuildListWithClss()

'Declare all the variables
Dim x As Long, arr1 As Variant, arr2 As Variant, lst As clssList
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

'Fill 1st array from sheet1
With Sheet1
    x = .Cells(.Rows.Count, 3).End(xlUp).Row
    arr1 = .Range("A2:C" & x).Value
End With

'Fill 2nd array from sheet2
With Sheet2
    x = .Cells(.Rows.Count, 3).End(xlUp).Row
    arr2 = .Range("A2:C" & x).Value
End With

'Load 1st array into dictionary with use of class
For x = LBound(arr1) To UBound(arr1)
    Set lst = New clssList
    lst.Number1 = arr1(x, 1)
    lst.NameSpec = arr1(x, 2)
    lst.PostBox = arr1(x, 3)
    dict.Add arr1(x, 2), lst
Next x

'Load 2nd array into dictionary with test
For x = LBound(arr2) To UBound(arr2)
    If dict.Exists(arr2(x, 2)) Then
        If Trim(arr2(x, 3)) = Trim(dict(arr2(x, 2)).PostBox) Then
            dict(arr2(x, 2)).Number2 = arr2(x, 1)
        Else
            Set lst = New clssList
            lst.Number2 = arr2(x, 1)
            lst.NameSpec = arr2(x, 2)
            lst.PostBox = arr2(x, 3)
            dict.Add arr1(x, 2) & "x", lst
        End If
    Else
        Set lst = New clssList
        lst.Number2 = arr2(x, 1)
        lst.NameSpec = arr2(x, 2)
        lst.PostBox = arr2(x, 3)
        dict.Add arr2(x, 2), lst
    End If
Next x

'Transpose dictionary into sheet3
With Sheet3
    x = 2
    For Each Key In dict.keys
        .Cells(x, 1).Value = dict(Key).Number1
        .Cells(x, 2).Value = dict(Key).Number2
        .Cells(x, 3).Value = dict(Key).NameSpec
        .Cells(x, 4).Value = dict(Key).PostBox
        x = x + 1
    Next Key
End With

如您所见，还有更多代码.但是IMO十分简洁易懂，而且当您的名字中有一个像我以前的代码那样包含管道符号时，它也不会对您造成伤害.

As you can see, a bit more code. But IMO it's rather clean and easy to understand and it won't bite you when one of your names include a pipe symbol as my previous code would.

这篇关于使用Excel VBA构建二分之一的列表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！