基于vba中两个范围的if语句构建循环

Question

预先感谢您的帮助。

我正在尝试构建一个宏（最终将成为更大宏的一部分），它将比较两个 ID，并根据发现将执行另一个操作。

我目前拥有的代码只复制每一行的值，而不考虑第一列中的 ID。 这是代码：

Sub movingValues()

    'declaring/setting variables

    Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
    Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
    Dim SheetOneRng As Range, SheetTwoRng As Range
    Dim cell As Range, i As Integer

    Application.Calculation = xlCalculationManual

    Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
    Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
    SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
    SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
    Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
    Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)

    SheetOneWs.Range("B2:D13").Value = ""

    For i = 2 To SheetTwoLastRow
        'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "No" Then
                SheetOneWs.Cells(cell.Row, "B").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "B").Value = "No data"
        Next cell
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "Maybe" Then
                SheetOneWs.Cells(cell.Row, "C").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "C").Value = "No data"
        Next cell
        For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
            If cell.Value = "Yes" Then
                SheetOneWs.Cells(cell.Row, "D").Value = SheetTwoWs.Cells(1, cell.Column)
                Exit For
            End If
            SheetOneWs.Cells(cell.Row, "D").Value = "No data"
        Next cell

    Next i


    Application.Calculation = xlCalculationManual
End Sub

我的理解是我需要将它放在另一个循环中以匹配 ID，到目前为止我已经尝试过：

For i = 2 To SheetOneLastRow


    For a = 2 To SheetTwoLastRow


    valTwo = Worksheets("SheetTwo").Range("A" & a).Value

    If Cells(i, 1) = valTwo Then

     'CODE FROM ABOVE'

    End if
  Next a
Next i

似乎也没有按照我的预期工作，您的所有帮助将不胜感激。 该代码最初取自此处的答案： 根据条件将值从一张纸复制到另一张 VBA 的问题

再次感谢您的所有回答。

最好的问候，谢尔盖

Answer 1

因为我真的不忍心看你那极其低效的代码，所以我根据你上一个问题中提供的数据在这里重新编写了它。

它的作用是遍历工作表 2 的 A 列。然后为每个单元格找到相应的 ID 并将该行存储在“Hit”中。

然后它在单元格的行中找到三个值，并将与每个命中相关联的月份添加到数组中的正确位置。

然后它将数组一次性粘贴到工作表 1 中的正确范围。

Sub movingValues()

    Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
    Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
    Dim cel As Range, hit As Range
    Dim Foundrow As Integer
    Dim arr() As Variant

    Application.Calculation = xlCalculationManual

    Set SheetOneWs = ThisWorkbook.Worksheets("Sheet1")
    Set SheetTwoWs = ThisWorkbook.Worksheets("Sheet2")
    SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
    SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row

    ReDim arr(1 To SheetOneLastRow - 1, 1 To 3)

    For Each cel In SheetTwoWs.Range("A2:A" & SheetTwoLastRow)
        Foundrow = SheetOneWs.Range("A1:A" & SheetOneLastRow).Find(cel.Value).Row - 1
            If Not Foundrow = 0 Then
                Set hit = SheetTwoWs.Rows(cel.Row).Find("No", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 1) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 1) = "No Data"
                End If
                Set hit = SheetTwoWs.Rows(cel.Row).Find("Maybe", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 2) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 2) = "No Data"
                End If
                Set hit = SheetTwoWs.Rows(cel.Row).Find("Yes", SearchDirection:=xlNext)
                If Not hit Is Nothing Then
                    arr(Foundrow, 3) = SheetTwoWs.Cells(1, hit.Column).Value
                        Else
                        arr(Foundrow, 3) = "No Data"
                End If
            End If
    Next cel

    SheetOneWs.Range("B2:D" & SheetOneLastRow) = arr

End Sub

正如您在尝试时可能看到的那样，首先将您的值读入数组会使这非常即时，因为它节省了“昂贵”的写入操作。 有了测试和这个结构，它应该比你以前的代码更直接和严格。 使用Find意味着它只需要遍历每一行一次，从而进一步提高性能。

请注意，最好在尝试之前备份您的数据，以防出现意外结果和/或错误。

Answer 2

据我所知，这就是你想要的。

Sub x()

Dim rID As Range, rMonth As Range, rData As Range, rCell As Range, v As Variant

With Worksheets("SheetTwo")
    Set rID = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    Set rMonth = .Range("B1:M1")
    Set rData = .Range("B2").Resize(rID.Rows.Count, rMonth.Columns.Count)
End With

With Worksheets("SheetOne")
    For Each rCell In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
        v = Application.Match(rCell.Value, rID, 0)
        If IsNumeric(v) Then
            rCell.Offset(, 1).Value = rMonth.Cells(Application.Match("No", rData.Rows(v), 0))
            rCell.Offset(, 2).Value = rMonth.Cells(Application.Match("Maybe", rData.Rows(v), 0))
            rCell.Offset(, 3).Value = rMonth.Cells(Application.Match("Yes", rData.Rows(v), 0))
        End If
    Next rCell
End With

End Sub