如果其他两列的值匹配，则将值从一张工作表中的单元格复制到另一张工作表中最后使用的列中的单元格

Question

使用VBA可能无法做到这一点。 我有一个建筑图纸寄存器，每个图纸使用1行，每列分别包含图纸编号，图纸名称，比例和纸张尺寸。 从“ O”列开始跟踪发布的信息。

发布信息时，该信息的当前修订版会在发布日期的下方进行标记。

我们用于开发图纸信息的软件包含的数据包括最新版本。 我想做的是将工程图编号和当前修订值导出到excel，然后自动将该信息带入正确位置的工程图寄存器上的最后发布日期。 我希望通过用Sheet3（“修订”）列A的内容搜索Sheet1（000模型，ACAD ...）列A的内容来确保正确的行，并且当它在Sheet1上找到匹配项时，复制Sheet3的对应单元格从B列到匹配行的最后一列。

到目前为止（更新的图像）：我以前已经更新了工作表的简化版本，但是现在已经上传了原始版本。

如您在工作表1的图像中看到的，有两个按钮。 一种可以在提示的输入日期之前隐藏所有问题，另一种则无法生效的更新修订...

Sheet2（列表）仅用于存储在宏计算和数据计算中使用的值（没有足够的代表来发布第三个链接...）。 由于我使用“隐藏/显示旧发行日期”按钮的findCol宏，最后一列号被记录为Sheet3单元AA3中的值，我希望可以将其用于定义列以将当前修订版复制到。 AA和AJ列存储此宏中使用的信息。

Sheet3（修订版）包含从Revit导出的每个工程图的导出工程图编号和当前修订版。 在此过程中，我看到应从导出的“独立” Excel工作表中复制这些数据，并对其进行操作以使用当前修订填充问题工作表，然后将其删除。

我遇到麻烦的那段代码是我试图在Sheet1的H列中为Sheet3中的值找到匹配值的地方。 在找到匹配项的地方，我要将单元格值从Sheet3复制到Sheet1中相应行的最后一列。

Sub updateRevs()
Set i = Sheets("Sheet1")
Set r = Sheets("Revisions")
Dim d
d = 1
Dim j As Range
Dim LastRow As Long
LastRow = r.Range("A" & Rows.Count).End(xlUp).Row
Do Until IsEmpty(r.Range("A" & j))
For j = 1 To LastRow
    If r.Range("A" & d).Value = i.Range(j, 8).Value Then
        r.Range("B" & d).Copy
        i.Range(j, Sheet2.Range("AA3").Value).PasteSpecial xlPasteValues
    End If
Next j
d = d + 1
Loop
End Sub

“更新修订”按钮的宏调用顺序如下：

Sub MakeNewSheet()
Sheets.Add.Name = "Revisions"
End Sub

Sub copyRevisions()
Application.FileDialog(msoFileDialogFilePicker).Show
Sheet2.Range("AJ1").Value = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
Dim x As Workbook
Dim y As Workbook
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Set x = ThisWorkbook
Set y = Workbooks.Open(Sheet2.Range("AJ1").Value)
y.Sheets("Revisions").Range("A1:B" & lastRow).Copy
x.Sheets("Revisions").Range("A1").PasteSpecial
Application.CutCopyMode = False
y.Close
End Sub


Sub updateRevs()
Set i = Sheets("Sheet1")
Set r = Sheets("Revisions")
Dim d
d = 1
Dim j As Range
Dim LastRow As Long
LastRow = r.Range("A" & Rows.Count).End(xlUp).Row
Do Until IsEmpty(r.Range("A" & j))
For j = 1 To LastRow
    If r.Range("A" & d).Value = i.Range(j, 8).Value Then
        r.Range("B" & d).Copy
        i.Range(j, Sheet2.Range("AA3").Value).PasteSpecial xlPasteValues
    End If
Next j
d = d + 1
Loop
End Sub

Sub deleteRevSheet()
Application.DisplayAlerts = False
Sheets("Revisions").Delete
End Sub

任何帮助将不胜感激（即使可以说在VBA中也可能！）

谢谢！

更新了工作代码，可能需要对其进行微调：

Sub updateRevisions()
Dim i As Worksheet
Dim r As Worksheet
Dim LastRow As Long
Dim LastRowSheets As Long
Set i = ThisWorkbook.Sheets("000 MODELS, ACAD...")
Set r = ThisWorkbook.Sheets("Revisions")
Dim FirstAddress As String
Dim Rng As Range
Dim e As Long
Dim check() As String
Dim cell As Range
Dim j As Integer
j = 1
Dim Col As Long
Col = Sheet2.Range("AB1").Value


LastRow = r.Cells(Rows.Count, "A").End(xlUp).Row
LastRowSheets = i.Cells(Rows.Count, "H").End(xlUp).Row

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

With Sheet1.Range("H51:H" & LastRowSheets)
ReDim check(j)
    For Each cell In r.Range("A2:A" & LastRow)
        check(j) = cell
            For e = LBound(check()) To UBound(check())
                Set Rng = .Find(What:=check(j), _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                Rng.Offset(0, Col).Value = r.Cells(j + 1, "B").Value
                Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                End If
            Next e
        j = j + 1
    ReDim Preserve check(j)
Next
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

Answer 1

由于一些问题，子updateRevs无法工作：

1. 您将j声明为范围，然后将其用作数字。
2. 设置LastRow的行不明确，应包含工作表（ r.Rows.Count ）。
3. “ Do Until循环永远不会结束，因为j只是从1到LastRow （仍包含数据）。 因此，这是一个无限循环，使代码永远运行。 我不太确定您想在这里实现什么。 因此，我不知道建议什么作为改进。
4. 您有时使用Range和两个数字来引用单元格。 但是，只有Cells才有可能。 因此，我将其中一些更改为Cells 。 但是，这里的参考是Cells(rowNumber, columnNumber) 。 因此，您可能需要查看这些更改。

这些更改后的结果代码如下：

Sub updateRevs()

Dim d As Long
Dim j As Long
Dim LastRow As Long
Dim i As Worksheet
Dim r As Worksheet

d = 1
Set i = ThisWorkbook.Sheets("Sheet1")
Set r = ThisWorkbook.Sheets("Revisions")

LastRow = r.Range("A" & r.Rows.Count).End(xlUp).Row

Do Until IsEmpty(r.Range("A" & j))
    For j = 1 To LastRow
        If r.Range("A" & d).Value = i.Cells(j, 8).Value Then
            r.Range("B" & d).Copy
            i.Cells(j, Sheet2.Range("AA3").Value).PasteSpecial xlPasteValues
        End If
    Next j
    d = d + 1
Loop

End Sub

_{如前所述，该代码将导致无限循环，并且必须进一步调整。 最有可能您可以完全删除循环。 但是，我不知道d = d + 1是做什么的？}

_{还要注意，此“答案”更多是一些提示的集合，可以使您朝正确的方向（而不是完整的答案）进行操作。 这是由于以下事实：我目前无法看到您希望通过循环实现的目标。}