Question

在工作表2中，A列中有一组规则。

A列中的示例每行中有多个代码，B行到H行的数据基于与该代码对应的数据。

在Sheet 1中，我希望能够放置其中一个代码，并且如果此代码与A列中的代码匹配，则从表2中将VBA传输行B：H。

这是我到目前为止的程序，它传输的是行，但不是右行。

    Dim i As Integer
    Dim x As Integer
    Dim row As Integer
    Dim oldRow As Integer
    Dim found As Boolean
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    Dim rng As Range, cell As Range, rng2 As Range, cell2 As Range

Set rng2 = ws2.Range("A1:A212")
Set rng = ws1.Range("A1:A212")

row = 1
oldRow = 1


For Each cell In rng
    row = row + 1

    For Each cell2 In rng2
        oldRow = oldRow + 1

        If cell.Value = cell2.Value Then
        row = row - 1
            ws1.Cells(row, 2) = ws2.Cells(oldRow, 2)
            ws1.Cells(row, 3) = ws2.Cells(oldRow, 3)
            ws1.Cells(row, 4) = ws2.Cells(oldRow, 4)
            ws1.Cells(row, 5) = ws2.Cells(oldRow, 5)
            ws1.Cells(row, 6) = ws2.Cells(oldRow, 6)
            ws1.Cells(row, 7) = ws2.Cells(oldRow, 7)
            ws1.Cells(row, 8) = ws2.Cells(oldRow, 8)
            found = True
        End If



    Next
    found = False
    oldRow = 1

Next

End Sub

感谢您的帮助，谢谢。

Answer 1

未测试：

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range, f As Range, rng2 As Range
Dim c as range, cell as Range


Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:A212")
Set rng2 = ws2.Range("A1:A212")

row = 1
oldRow = 1


For Each cell In rng.Cells
    if len(cell.value)>0 Then
        Set f = rng2.Find(cell.Value, lookin:=xlvalues, lookat:=xlWhole)
        if not f is nothing then
            cell.offset(0,1).Resize(1,7).Value = _
               f.offset(0,1).resize(1,7).Value
        end if   
    end if   
Next cell

Answer 2

这需要在VBA中吗？或者您是否可以使用VLOOKUP工作表功能？因为这实际上是你想从事物的声音中实现的目标。

您还可以使用VLOOKUP

在VBA中使用Application.WorksheetFunction.VLookup

您的问题可能是因为您在循环开始时而不是在结尾处递增row和oldRow ..所以第一次运行它们的值将是2而不是1。你也可能不需要做row = row - 1，因为它令人困惑。

Answer 3

你可以这样做公式。在'Sheet1'单元格B1上并上下复制：

=IF(COUNTIF(Sheet2!$A:$A,$A1)=0,"",VLOOKUP($A1,Sheet2!$A:$H,COLUMN(B1),0))

如果它必须是一个宏，那么这样的东西应该适合你：

Sub tgr()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rngFound As Range
    Dim arrCodes As Variant
    Dim arrResults As Variant
    Dim varCode As Variant
    Dim ResultIndex As Long
    Dim cIndex As Long

    Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    Set ws2 = ActiveWorkbook.Sheets("Sheet2")

    arrCodes = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp)).Value
    If Not IsArray(arrCodes) Then Exit Sub  'No data
    ReDim arrResults(1 To UBound(arrCodes, 1), 1 To 7)

    For Each varCode In arrCodes
        ResultIndex = ResultIndex + 1
        Set rngFound = ws2.Columns("A").Find(varCode, , xlValues, xlWhole)
        If Not rngFound Is Nothing Then
            For cIndex = 1 To UBound(arrResults, 2)
                arrResults(ResultIndex, cIndex) = WorksheetFunction.VLookup(varCode, ws2.Range("A:H"), cIndex + 1, False)
            Next cIndex
        End If
    Next varCode

    ws1.Range("B1").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults

End Sub

Answer 4

我会改变这样的代码：

Sub test()
    Dim i As Integer
    Dim n As Integer
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    'Cycles through the codes in sheet 1
    For i = 2 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).row Step 1
        For n = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).row Step 1
            If ws1.Cells(i, 1).Value = ws2.Cells(n, 1).Value Then
                ws1.Cells(i, 2).Value = ws2.Cells(n, 2).Value
                ws1.Cells(i, 3).Value = ws2.Cells(n, 3).Value
                ws1.Cells(i, 4).Value = ws2.Cells(n, 4).Value
                ws1.Cells(i, 5).Value = ws2.Cells(n, 5).Value
                ws1.Cells(i, 6).Value = ws2.Cells(n, 6).Value
                ws1.Cells(i, 7).Value = ws2.Cells(n, 7).Value
                ws1.Cells(i, 8).Value = ws2.Cells(n, 8).Value
            End If
        Next n
    Next i
End Sub

基于值在工作表之间复制行

4 个答案: