VBA 查找和替换行条目

Question

我正在尝试编写一个基本上执行以下操作的函数：

1. 从工作簿 #1 中获取“名称”单元格值
2. 从工作簿 #1 中获取“金额”单元格值
3. 打开第二个工作簿（这是一个 2 列列表，其中 columnA = “Names”，columnB = “Amounts”）
4. 扫描第二个工作簿的 A 列以查找重复的“名称”条目（来自步骤 1）
5. 如果存在重复项，则使用步骤 2 中存储的值覆盖 B 列中相应的“金额”值
6. 如果 no 重复存在，则将新的最后一行追加到列表中
7. 在第二个工作簿的 A 列的最后一行写入“名称”
8. 在第二个工作簿的 B 列最后一行写入“金额”

本质上，此函数将更新名称列表及其相应数量。如果列表中已存在名称，则此脚本将在 A 列中查找重复条目，并更新同一行 B 列中的关联金额。如果此列表中不存在名称，该函数将向列表中添加一个新行，然后将存储的“名称”值写入 A 列，并将存储的“金额”值写入 B 列。

我已经完成了第 1-3 步，但在为第 4-8 步创建循环时遇到了一些问题。这是我目前拥有的代码...任何帮助将不胜感激！

谢谢！

Sub Open_Updator()

Dim proj_name As String
Dim amount As Double
Dim updator As Workbook
Dim updator_sheet As Worksheet
Dim LastRow As Long
Dim arr() As Variant
Dim R As Long
Dim C As Long
Dim Destination As Range

proj_name_raw = ThisWorkbook.Sheets("Cover").Range("C7").Value
proj_name = Left(proj_name_raw, Len(proj_name_raw) - 3)
amount = ThisWorkbook.Sheets("Summary").Range("O110").Value

Set updator = Workbooks.Open(Filename:="C:\Users\XXXXX\Desktop\updator.xlsx")
updator.Activate

Set updator_sheet = Sheets("Table")

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
arr = Range("A1:B" & LastRow)
Set Destination = Range("A1")

For R = 1 To UBound(arr, 1)
    For C = 1 To UBound(arr, 2)
        If arr(R, C) = proj_name Then arr(R, C) = arr(R, 1)
    Next C
Next R

Destination.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

End Sub

谢谢！

Answer 1

好的。试试这个：

    Private Sub Test()

        Dim WB1 As Worksheet
        Set WB1 = Workbooks.Open(Filename:="WB1.xlsx").Sheets("Sheet1")
        Dim LastRow As Long
        Dim LastRowWB1 As Long

        LastRow = Cells(Rows.Count, "A").End(xlUp).Row

        LastRowWB1 = WB1.Cells(Rows.Count, "A").End(xlUp).Row

        j = 1

        For r = 2 To LastRowWB1
            Name = WB1.Cells(r, "A").Value
            For x = 2 To LastRow + j
                If Cells(x, "A").Value = Name Then
                    Cells(x, "B") = WB1.Cells(r, "B")
                    Exit For
                ElseIf Cells(x, "A") = "" Then
                    Cells((LastRow + j), "A") = WB1.Cells(r, "A").Value
                    Cells((LastRow + j), "B") = WB1.Cells(r, "B").Value
                    j = j + 1
                End If
            Next x
        Next r

    End Sub

您也可以使用查找：

Private Sub Test2()

    Dim WB1 As Worksheet
    Set WB1 = Workbooks.Open(Filename:="U:\Temp\WB1.xlsx").Sheets("Sheet1")
    Dim LastRow As Long
    Dim LastCol As Long
    Dim SrchInArray As Range

    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    LastRowWB1 = WB1.Cells(Rows.Count, "A").End(xlUp).Row

    j = 1
    Set SrchInArray = Range(Cells(2, "A"), Cells(LastRow, "A"))

    For r = 2 To LastRowWB1
        Name = WB1.Cells(r, "A").Value
        Set y = SrchInArray.Find(WB1.Cells(r, "A").Value, , xlValues, xlWhole, xlByRows, xlNext, False, False, False)
        If Not y Is Nothing Then
            Cells(y.Row, "B") = WB1.Cells(r, "B").Value
        Else
            Cells(LastRow + j, "A") = WB1.Cells(r, "A").Value
            Cells(LastRow + j, "B") = WB1.Cells(r, "B").Value
            j = j + 1
        End If
    Next r

End Sub

您将不得不调整一些名称。代码假定两个工作簿中的第 1 行都有标签，名称和值从第 2 行开始。

如果您在某个地方卡住了，请告诉我，以便我们解决。否则，请提供您的工作簿示例以调整代码。