更改数组中元素的值并将结果粘贴到命名范围

Question

我正在自动化我的工作流程，并试图解决将来会出现的一些问题。我的部分流程是导入不同的电子表格，查找员工姓名，然后找出他们的经理是谁。我面临的问题是人们在不同的系统上被称为不同的名字。例如，名为“Donald Donaldson”的人在系统上可能被称为“Don Donaldson”，但他的全名在员工名单上。或者，戴夫戴维森是系统上的戴维戴维森。

这会发生很多次（因为有些人在系统列表中出现了 2 次），并且会减慢整个过程，而我的同事会手动解决问题。为了解决这个问题，我在我的数据选项卡上创建了 3 个表/动态命名范围。每张表（如下所示）都有不同的用途；错误名称列表（“名称”）、替换名称列表（“Rep”）和从系统中提取的名称列表（“比较”）。我想查看比较列表以查看是否出现任何“名称”实例。如果它找到一个实例，那么它将用正确的名称替换名称

我觉得我已经非常接近完成需要完成的任务，但我缺乏那一刻的辉煌来帮助我突破。

我的方法

我有 3 个动态命名范围（范围长度会根据从其他文件中提取的内容而变化），并且我将它们存储为 3 个动态数组（出于这个原因）。我的代码循环遍历 Names 中的每个元素、Rep 中的每个元素和 Compare 中的每个元素。如果 Compare (z) 中的值等于 Names (x) 中的值，那么我们将它的值更改为 Rep 中的值（因此 z = y） 问题在于只有 z 的值会发生变化，并且不是我数组中的相应值。即唐唐纳森是比较中的第三个元素。我找到了一个匹配项，因此 Z 从 Don Donaldson 更改为 Donald Donaldson。然而，Compare(3) 仍然是 Don Donaldson。

我尝试制作第 4 个动态数组，并使用 ReDim 在每次迭代时增加它的长度。每次匹配时 myArr(index) 都等于 y，并且在循环之后将第四个命名范围（“TestRange”）设置为此数组的值，这种方法也不起作用。

有人可以帮助我吗？如何更改数组中元素的值（比较）以及如何将这个新数组输出到命名范围？

我的代码和我的数据示例如下所示。

请帮忙。谢谢

Sub mySub()
    Dim Arr() As Variant
    Arr = Worksheets("Data").Range("Names").Value
    Dim comArr() As Variant
    comArr = Worksheets("Data").Range("Compare").Value
    Dim repArr() As Variant
    repArr = Worksheets("Data").Range("Rep").Value
    Dim comInt As Integer
    comInt = 0
    Dim RowCounter As Long
    Dim ArrayCounter As Long

    Dim x As Variant
    Dim y As Variant
    Dim z As Variant
    Dim zInt As Integer
    zInt = 0
    Dim myArr() As Variant

    For Each x In Arr
        For Each y In repArr
            For Each z In comArr
                'ReDim myArr(0 To zInt) As Variant
                If z = x Then
                    z = y
                    'myArr(zInt) = y
                End If
                zInt = zInt + 1
            Next z
        Next y
    Next x

    'Worksheets("Data").Range("TestRange").Value = comArr()
    'Worksheets("Data").Range("TestRange").Value = myArr()
End Sub

*我的命名范围 对不起，混乱的布局

“姓名” 唐唐纳森， 大卫戴维森， 迈克迈克尔斯， 帕特帕特森， 史蒂夫·史蒂文森 杰克杰克逊， 罗伯特·罗伯逊 哈维哈维， 约翰·约翰逊

“代表” 唐纳德·唐纳森 戴夫戴维森， 迈克尔迈克尔斯， 帕特里克·帕特森， 史蒂文·斯蒂芬森 杰克杰克逊， 罗伯逊， 哈维·哈维 乔恩·约翰逊

“比较” 唐唐纳森， 迈克迈克尔斯， 杰克杰克逊， 约翰约翰逊， 帕特帕特森， 珀西·帕金斯， 唐唐纳森， 汤姆汤姆森， 哈维哈维， 马克·马库斯 克里斯克里斯托弗森， 米奇·米切尔， 杰克杰克逊， 罗伯逊

Answer 1

这应该是一个注释，但它太长了，我想为你提供一些代码。

我认为你的代码逻辑是错误的......（伪代码）

if z(Don Donaldson) = x(Don Donaldson) >> myArr(?) = Don Donaldson 

有 55 种情况符合这种比较。但是您无法检查 y(Donald Donaldson) 中的对应元素。为此，您需要具有与每个数组（元素）匹配的任何参数，或者您需要使用此处不可用的任何 key index。此外，每个数组中有不同数量的元素。在我看来，您只能通过手动处理您拥有的此类数据集来解决它。

部分检查我建议尝试将循环的内部部分更改为此代码：

'...your code here
        For Each z In comArr

            If z = x Then
                ReDim Preserve myArr(zInt) As Variant
                z = y
                myArr(zInt) = y
                zInt = zInt + 1
            End If

        Next z
'your code here

如果您另外将最后注释的行更改为此并取消注释以查看结果：

Worksheets("Data").Range("TestRange").Value = Application.Transpose(myArr)

Answer 2

正如我所说，我设法为这个问题收集了另一个解决方案，但是它不使用数组或命名范围。代码如下

Sub RangesArrays()

    Dim FoundOne As Range, extractNames As Range, exceptionNames As Range, c As Range
    Application.ScreenUpdating = False


   'This is the Compare list
    Worksheets("ExtractSheet").Activate
    Set extractNames = Worksheets("ExtractSheet").Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    'This is the Names
    Worksheets("Data").Activate
    Set exceptionNames = Worksheets("Data").Range(Range("D1"), Range("D" & Rows.Count).End(xlUp))


    'Loops through names list. C is an element
    For Each c In exceptionNames
        With extractNames
            'This looks for c
            Set FoundOne = .Find(What:=c, LookAt:=xlPart)
            If Not FoundOne Is Nothing Then
                'If there is a match then it looks to replace the current name with the     replacement
                'name. What is FoundOne, and replacement is what is on the cell directly     to the lsit
                'name.offset(0 on x, 1 on y)
                extractNames.Replace What:=FoundOne, Replacement:=c.Offset(0, 1).Value, LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
            End If
        End With
    Next c
    'Reset values to default
    Set extractNames = Nothing: Set exceptionNames = Nothing
    Application.ScreenUpdating = True


End Sub