使用Excel VBA从两个列表中生成一个列表_Excel_Vba

使用Excel VBA从两个列表中生成一个列表

excel vba

使用Excel VBA从两个列表中生成一个列表,excel,vba,Excel,Vba,我正在构建一个应用程序，首先将数据从一个工作簿复制到另一个工作簿，这已经在工作了然后是最复杂的部分，我还不确定这是否可能。有两个数据列表第一张表格1：第二张第2页：代码应比较B列和C列，并将新列表构建为Sheet3，如下所示：因此，首先构建Sheet3，在比较之后，如果发现重复项，则将值添加到相应的列B。如果未找到重复项，则使用数据创建新行这是我检测重复的代码 Sub CheckAvailability() Dim rMyRng As Range, rCompare As Ran

我正在构建一个应用程序，首先将数据从一个工作簿复制到另一个工作簿，这已经在工作了

然后是最复杂的部分，我还不确定这是否可能。有两个数据列表

第一张表格1：

第二张第2页：

代码应比较B列和C列，并将新列表构建为Sheet3，如下所示：

因此，首先构建Sheet3，在比较之后，如果发现重复项，则将值添加到相应的列B。如果未找到重复项，则使用数据创建新行

这是我检测重复的代码

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

在我当前的代码中，我将此作为输出，这是正确的。如何使所有其他的工作

不确定这是否是最好的方法，因为它非常广泛，但想试试字典=。希望它能帮上忙

字典连接的数组

使用从两个列表填充的两个数组迭代第一个数组以将项加载到字典中迭代第二个数组以检查它们是否存在于字典中。如果是，请检查邮箱号码并采取相应措施迭代字典以将其值转换为sheet3 带字典类模块的数组

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

现在，我们可以通过这个类模块设置新对象，并用它们填充字典，而不是前面的代码：

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

正如您所看到的，更多的代码。但在我看来，它相当简洁易懂，而且当你的名字中有一个像我之前的代码那样包含管道符号时，它不会咬你。

不确定这是否是最好的方法，因为它非常广泛，但感觉像是在尝试一些字典=。希望它能帮上忙

字典连接的数组

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

现在，我们可以通过这个类模块设置新对象，并用它们填充字典，而不是前面的代码：

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

正如您所看到的，更多的代码。但在我看来，它相当简洁易懂，而且当你的名字中有一个像我之前的代码那样包含管道符号时，它不会咬你。

另一个未经测试的字典解决方案：

Sub Main()
    Dim dict As Scripting.Dictionary
    Set dict = New Scripting.Dictionary

    Dim cell As Range
    With Worksheets("Sheet1")
        For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) = cell.Value2 & " "
        Next
    End With

    With Worksheets("Sheet2")
        For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) = dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) & " " & cell.Value2
        Next
    End With

    Dim key As Variant
    Dim iRow As Long
    With Worksheets("Sheet3")
        For Each key In dict.Keys
            .Range("A1:B1").Offset(iRow).Value = Split(Replace(dict(key), "  ", " "), " ")
            .Range("C1:D1").Offset(iRow).Value = Split(key, "|")
            iRow = iRow + 1
        Next
    End With
End Sub

另一个未测试的字典解决方案：

Sub Main()
    Dim dict As Scripting.Dictionary
    Set dict = New Scripting.Dictionary

    Dim cell As Range
    With Worksheets("Sheet1")
        For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) = cell.Value2 & " "
        Next
    End With

    With Worksheets("Sheet2")
        For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) = dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) & " " & cell.Value2
        Next
    End With

    Dim key As Variant
    Dim iRow As Long
    With Worksheets("Sheet3")
        For Each key In dict.Keys
            .Range("A1:B1").Offset(iRow).Value = Split(Replace(dict(key), "  ", " "), " ")
            .Range("C1:D1").Offset(iRow).Value = Split(key, "|")
            iRow = iRow + 1
        Next
    End With
End Sub

可能通过一个简单的类模块和一个集合/字典？您想要VBA代码，还是可以手动执行？如果您想手动执行此操作，它非常简单。[1.]在各页中复制数字列，并临时插入名称列之后[2.]从两页中复制名称，并将其放入新页的A列中。单击数据|删除重复项[3]。将B栏中的数字1和C栏中的数字2添加到新表中。使用Vlookup从两个工作表中获取数字。如果要通过VBA执行此操作，则[1.]将两个工作表中的数据存储在两个不同的数组中[2.]从两个数组中创建一个唯一的名称集合[3.]为输出创建第三个数组[4.]使用3个循环搜索数据并将输出存储在第三个数组中[5.]第一个循环通过集合[6.]在第一个循环内，使用第二个循环搜索第一个数组[7]。在第一个循环内，使用第三个循环搜索第二个数组[8]。将第三个数组输出到新工作表必须是VBA吗？我相信sumproduct可以做到这一点，因为您可以将所有内容复制粘贴到一张工作表中。是的，它必须是VBA，因为我想构建VBS并每天在虚拟桌面上运行它—可能通过一个简单的类模块和集合/字典—您想要VBA代码，还是可以手动执行此操作？如果您想手动执行此操作，它非常简单。[1.]在各页中复制数字列，并临时插入名称列之后[2.]从两页中复制名称，并将其放入新页的A列中。单击数据|删除重复项[3]。将B栏中的数字1和C栏中的数字2添加到新表中。使用Vlookup从两个工作表中获取数字。如果要通过VBA执行此操作，则[1.]将两个工作表中的数据存储在两个不同的数组中[2.]从两个数组中创建一个唯一的名称集合[3.]为输出创建第三个数组[4.]使用3个循环搜索数据并将输出存储在第三个数组中[5.]第一个循环通过集合[6.]在第一个循环内，使用第二个循环搜索第一个数组[7]。在第一个循环内，使用第三个循环搜索第二个数组[8]。将第三个数组输出到新工作表必须是VBA吗？我相信sumproduct可以做到这一点

您可以将所有内容复制粘贴到一张工作表中。是的，它必须是VBA，因为我想构建VBS并每天在虚拟桌面上运行它。这很有效！现在我必须花一些时间来理解如何：@user7202022，为了更好地理解，请使用F8逐步完成代码。我试着这样写，它很容易理解，我希望这是可行的！现在我必须花一些时间来理解如何：@user7202022，为了更好地理解，请使用F8逐步完成代码。我试着这样写，它很容易理解，我希望这几乎有效，但如果输出表上有两个以上的单词，则将单词从句子中分割出来。一定是有分裂代码的东西。现在还没有调查yetWorks！不幸的是，我不能将两者都标记为答案…：/这是一个缺乏这个网站，如果两者都是很好的工作解决方案，为什么你应该选择其中一个…让事情保持原样。你将使用哪种解决方案？非常干净的方法。我个人唯一想做的事情是通过数组而不是单元格进行循环=谢谢@JvdV。至于数组循环，它肯定会更快，但也会弄脏代码……这几乎可以工作，但如果输出表上的单词超过2个，则会将单词从句子中分割出来。一定是有分裂代码的东西。现在还没有调查yetWorks！不幸的是，我不能将两者都标记为答案…：/这是一个缺乏这个网站，如果两者都是很好的工作解决方案，为什么你应该选择其中一个…让事情保持原样。你将使用哪种解决方案？非常干净的方法。我个人唯一想做的事情是通过数组而不是单元格进行循环=谢谢@JvdV。至于数组循环，它肯定会更快，但也会弄脏代码。。。