如果其他兩列的值匹配，則將值從一張工作表中的單元格復制到另一張工作表中最后使用的列中的單元格

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是做什么的？}

_{還要注意，此“答案”更多是一些提示的集合，可以使您朝正確的方向（而不是完整的答案）進行操作。 這是由於以下事實：我目前無法看到您希望通過循環實現的目標。}