VBA 循环/逻辑问题

Question

我正在为工作编写 excel 宏，但遇到了麻烦。在这种情况下，有两个工作表，“BU”和“TOPS 信息”。使用宏时，它应该在“BU”的每一行中搜索“TOPS 信息”中找到的值，然后转到“TOPS 信息”的下一行并重复该过程。如果找到正确的匹配项，则应该是复制一个单元格并将其粘贴到“TOPS 信息”中。

代码如下：

Sub QIM()

Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer

Dim searchArray(1 To 3) As String

j = 0
k = 1



'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row

'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1

    'Cycle through searchArray for each BU row
    For k = lastRowBU To 1 Step -1


            '//////////////////////////////////////

            x = Sheets("BU").Range("B" & k).Value
            y = Range("C" & j).Value

            If StrComp(x, y) = 1 Then



                Sheets("BU").Range("C" & k).Copy
                Range("H" & j).PasteSpecial



            End If

            '//////////////////////////////////////



    Next k

Next j


End Sub

这个宏显然只有在当时选择了“TOPS 信息”的情况下才有效。任何和所有的帮助将不胜感激。谢谢！

Answer 1

你自己回答了。 Range 是指当前的工作表，但是当你在四处弹跳时，你必须限定它。

使用适当的表格为您的范围添加前缀，

Sub QIM()

    Dim j As Integer
    Dim k As Integer
    Dim i As Integer
    Dim l As Integer
    Dim m As Integer

    Dim searchArray(1 To 3) As String

    j = 0
    k = 1



    'WARNING: Temporary Sheet Names
    lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
    lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row

    'Cycle through BU rows
    For j = lastRowTOPS To 1 Step -1

        'Cycle through searchArray for each BU row
        For k = lastRowBU To 1 Step -1
                '//////////////////////////////////////
                x = Sheets("BU").Range("B" & k).Value
                y = Sheets("TOPS Information").Range("C" & j).Value
                If StrComp(x, y) = 1 Then
                    Sheets("BU").Range("C" & k).Copy
                    Sheets("TOPS Information").Range("H" & j).PasteSpecial
                End If

                '//////////////////////////////////////

        Next k

    Next j


    End Sub

Answer 2

假设只想将BU中找到的最上面的数据复制到TOPS，您可以在下面使用。

Sub QIM()
    Dim oWS_TOPS As Worksheet, oWS_BU As Worksheet ' Worksheet objects
    Dim oRng_TOPS As Range, oRng_BU As Range ' Range objects
    Dim R_TOPS As Long, R_BU As Long

    Set oWS_TOPS = ThisWorkbook.Worksheets("TOPS Information") ' <-- Replace this "TOPS Information" to match future changes
    Set oWS_BU = ThisWorkbook.Worksheets("BU") ' <-- Replace this "BU" to match future changes

    R_TOPS = oWS_TOPS.Cells(Rows.Count, "A").End(xlUp).Row
    R_BU = oWS_BU.Cells(Rows.Count, "A").End(xlUp).Row

    ' Search column B of BU for each cell in column C of TOPS
    For Each oRng_TOPS In oWS_TOPS.Columns("C").Cells ' <-- Replace this "C" to match future changes
        ' Exit if row is more than last A column data
        If oRng_TOPS.Row > R_TOPS Then Exit For
        For Each oRng_BU In oWS_BU.Columns("B").Cells ' <-- Replace this "B" to match future changes
            ' Exit if row is more than last A column data
            If oRng_BU.Row > R_BU Then Exit For
            ' Check if Ranges match (## See Update ##)
            If InStr(1, oRng_TOPS.Value, oRng_BU.Value, vbTextCompare) > 0 Then
                ' Copy column C of found row in BU to column H of TOPS, then exit
                oWS_BU.Cells(oRng_BU.Row, "C").Copy oWS_TOPS.Cells(oRng_TOPS.Row, "H") ' <-- Replace these "C" and "H" to match future changes
                Exit For
            End If
        Next
    Next

    Set oWS_TOPS = Nothing
    Set oWS_BU = Nothing
End Sub

有很多方法可以实现您的目标，这就是其中之一。

---

更新 比较单元格值的注意事项（字符串）：

StrComp(S1,S2[,mode]) 只返回 3 个值 {-1, 0, 1} 来指示 S1 是否小于/等于/大于 S2。如果您想要完全匹配（区分大小写和精确间距），请使用 If StrComp(S1,S2) = 0 Then。

InStr([i,]S1,S2[,mode]) 只返回正值 - 它返回 S2 在 S1 中第一次出现的字符位置。如果未找到 S2，则返回零。

您还可以使用Trim(sText) 删除 sText 的前导/结尾空格。

希望下面的截图能说明更多。