Question

使用VBA可能无法实现。我有一个建筑图纸注册表，每个图纸使用1行，每列有图纸编号，图纸名称，比例和纸张尺寸。从列＆＃34; O＆＃34;跟踪发布的信息。向前。

发布信息时，该信息的当前版本标记在发布日期之下。

我们用于开发绘图信息的软件包含的数据包括最新版本。我想要做的是将图纸编号和当前版本值导出到Excel，然后自动将该信息带到正确行中图纸寄存器的最后一个发布日期。我希望通过使用Sheet3（＆＃34; Revisions＆＃34;）A列的内容搜索Sheet1 (000 MODELS, ACAD...) A列的内容来确保正确的行，当它在Sheet1上找到匹配时，复制Sheet3＆＃39 ;将来自B列的相应单元格转换为匹配的行＆＃39;最后一栏。

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

正如您在Sheet 1的图像中看到的，有两个按钮。在提示输入日期之前隐藏所有问题的一个，以及尚未运行的更新修订...

Sheet2（List）纯粹用于存储宏计算和数据计算中使用的值（不要有足够的rep来发布第3个链接......）。最后一列编号记录为Sheet3单元格AA3中的值，因为我使用的findCol宏用于隐藏/显示旧版本日期＆＃39;按钮，我希望可以用来定义要复制当前版本的列。列AA和AJ存储此宏中使用的信息。

Sheet3 (revisions)包含从Revit导出的每个图纸的导出图纸编号和当前版本。对于这个过程，我发现这些数据应该从导出的独立版本中复制出来。 excel sheet，操作以使用当前修订填充问题表，然后删除。

我遇到问题的代码就是我试图在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

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

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无法正常工作：

您声明j是一个范围，但然后将其用作数字。
您要设置LastRow的行不明确，应包含工作表（r.Rows.Count）。
Do Until循环永远不会结束，因为j只是从1传递到LastRow（仍然包含数据）。所以，这是一个无限循环使代码永远运行。我不太清楚你想在这里实现什么。因此，我不知道该改进是什么意思。
您有时使用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的用途是什么？！}

_{还要注意，这个“答案”更多的是一系列提示，以帮助您朝着正确的方向前进（而不是完整的答案）。这是因为我目前无法通过你的循环看到你想要实现的目标。}

将值从一个工作表中的单元格复制到另一个工作表中最后一个使用的列中的单元格，如果其他两个列中的值为＆＃39;值匹配

1 个答案: