Question

我需要找出如何编写一些基本代码，这些代码将从选定的范围内获取每个单元格的值（将是ID号），然后将其与主工作簿中的单元格匹配，复制该单元格的整个行，然后将其插入到原始文档中，代替ID号。关键在于：某些ID号可能与多个项目匹配，并且具有该编号的所有项目都必须重新插入文档中。这是一个示例：

Master Document              Workbook
A   B   C   D                A   B   C   D
1   a   ab  ac               2
2   b   bc  bd               3
2   b   be  bf               
3   c   cd  de

我将在工作簿中选择包含2和3的单元格，在运行代码后，它将得到以下提示：

Workbook
A   B   C   D
2   b   bc  bd
2   b   be  bf               
3   c   cd  de

到目前为止，这就是我要做的事情，但这完全是一团糟。成功完成的唯一操作是将所选范围存储在要粘贴到的工作簿中。不会编译过去，因为我对VBA的语法了解不多：

Sub NewTest()
Dim rng As Range
Dim FirstRow As Range
Dim CurrentCol As String
Dim FirstRowVal As Integer
Dim CurrentColVal As Variant
Dim rngOffset As Range

CurrentCol = "Blah"
Set FirstRow = Application.InputBox("Select the row containing your first raw material", Type:=8)
FirstRowVal = FirstRow.Row

Set rng = (Application.InputBox("Select the cells containing your IC numbers", "Obtain Materials", Type:=8))
Set rngOffset = rng.Offset(0, FirstRowVal)
CurrentColVal = rng.Column

Call CopyPaste

End Sub

Sub CopyPaste()
Dim Blah As Range
Set x = Workbooks.Open("Workbook Path")
Workbooks.Open("Workbook Path").Activate


Set y = Workbooks.Open("Master Path")
Workbooks.Open("Master Path").Activate

With x
For Each Cell In rng
x.Find(rng.Cell.Value).Select
If Selection.Offset(0, -1) = Selection Then
Selection.EntireRow.Copy
Selection = Selection.Offset(0, -1)
Else
Selection.EntireRow.Copy
Blah = Selection
End If
Workbooks.Open("Workbook Path").Activate
Sheets("Formula Sheet").Select
Blah.Insert (rng.Cell)
End

Sheets("sheetname").Cells.Select
Range("A1").PasteSpecial
'Sheets("sheetname").PasteSpecial
.Close
End With

With x
.Close
End With
End Sub

非常感谢任何能帮助我指出正确方向的人。谢谢。

Answer 1

我要咬一口，您可以使用输出数组填充任何工作表上的任意范围。

Sub FindAndMatch()

    Dim arrMatchFrom() As Variant, arrMatchTo() As Variant, arrOutput() As Variant
    Dim i As Integer, j As Integer, counter As Integer

    counter = 0

    arrMatchFrom = Range("A2:D6")
    arrMatchTo = Range("G2:G3")

    For i = LBound(arrMatchTo, 1) To UBound(arrMatchTo, 1)
        For j = LBound(arrMatchFrom, 1) To UBound(arrMatchFrom, 1)
            If arrMatchTo(i, 1) = arrMatchFrom(j, 1) Then
                counter = counter + 1
                ReDim Preserve arrOutput(4, counter)
                arrOutput(1, counter) = arrMatchTo(i, 1)
                arrOutput(2, counter) = arrMatchFrom(j, 2)
                arrOutput(3, counter) = arrMatchFrom(j, 3)
                arrOutput(4, counter) = arrMatchFrom(j, 4)

            End If
        Next
    Next

    For i = 1 To counter
        For j = 1 To 4
            Debug.Print arrOutput(j, i)
            Cells(9 + i, j) = arrOutput(j, i)
        Next
    Next

End Sub

需要帮助在Excel VBA中从一个工作簿复制/粘贴到另一个工作簿

1 个答案: