仅在满足文本条件时执行匹配应用程序

Question

我有以下VBA脚本，它匹配工作表1的第J列中的所有文本行到工作表2的B列.Catch是，它应该只匹配工作表1的H列中包含单词“Active”的值

但是，我无法运行它。任何建议表示赞赏。

Option Explicit

Private Sub CommandButton8_Click()

    Dim w1 As Worksheet, w2 As Worksheet
    Dim c As Range, FR As Long
    Dim status As String
    Dim bottomH As Long
    Dim rng As Range
    Dim lastrow As Long
    Dim i As Integer

    Application.ScreenUpdating = False

    Set w1 = Workbooks("Mastersheet_test.xlsm").Worksheets("Master")
    Set w2 = Workbooks("Mastersheet_test.xlsm").Worksheets("Gross Profit")
    bottomH = w1.Range("H" & Rows.Count).End(xlUp).Row
    lastrow = w1.Range("H10000").End(xlUp).Row
    Set rng = w1.Range(Cells(7, 8), Cells(lastrow, 10))

    For Each c In rng
        'For i = 7 To bottomH
        FR = 0
        On Error Resume Next
        FR = Application.Match(c, w2.Columns("B"), 0)
        On Error GoTo 0
        For i = 7 To bottomH
            status = w1.Cells(i, 8).Value
            If status = "Active" Then
                If FR <> 0 Then w2.Range("C" & FR).Value = c.Offset(, 9)
                If FR <> 0 Then w2.Range("D" & FR).Value = c.Offset(1, 9)
                If FR <> 0 Then w2.Range("E" & FR).Value = c.Offset(, 10)
                If FR <> 0 Then w2.Range("F" & FR).Value = c.Offset(1, 10)
                If FR <> 0 Then w2.Range("G" & FR).Value = c.Offset(, 7)
                If FR <> 0 Then w2.Range("H" & FR).Value = c.Offset(, 8)
            End If
        Next
    Next c

    Application.ScreenUpdating = True
    w2.Activate

End Sub