标出标准为1的顶部和底部区域单元格

Question

Excel表如下：

RowID, A, B, C
1, amazon.com,
2, amazon.com, 
3, amazon.com, ecommerce, 1
4, amazon.com, 
5, amazon.com, 
6, outlook.com, mailbox, 1
7, outlook.com, 
8, outlook.com,
9, outlook.com,
10, outlook.com,
11, cloudera.com, cloud services

问题：

查找C列中的值1，得到B列中的值，填充第1-2行和第4-5行，因为A列是amazon.com

使用amazon.com完成后，查找下一个值1，填充行7-10，因为A列是outlook.com

预期产出：

RowID, A, B, C
1, amazon.com, ecommerce
2, amazon.com, ecommerce
3, amazon.com, ecommerce, 1
4, amazon.com, ecommerce
5, amazon.com, ecommerce
6, outlook.com, mailbox, 1
7, outlook.com, mailbox
8, outlook.com, mailbox
9, outlook.com, mailbox
10, outlook.com, mailbox
11, cloudera.com, cloud services

我尝试了以下几点：

Sub test()    
    Dim ws As String
    Dim t, lr, fr, nr As Long

    ws = ActiveSheet.Name
    lr = Sheets(ws).Cells(Rows.Count, 1).End(xlUp).Row
    t = 1
    nr = 1

    Do Until t = lr
        Set val1 = Sheets(ws).Range("C" & t & ":C" & lr).Cells.Find(what:="1")
        If Not val1 Is Nothing Then
            Set val2 = Sheets(ws).Range("B1:B" & lr).Cells.Find(what:="")
            fr = val2.Row - 1
            nr = val1.Row - 1

            Range("B" & fr).Copy
            Range("B" & fr + 1 & ":B" & nr).Select
            Selection.PasteSpecial Paste:=xlPasteValues
        End If

        t = nr + 2
    Loop
End Sub

知道怎么修改代码吗？

Answer 1

更新代码# 4

请注意，代码在D列中添加了一个“助手”公式(它将在末尾移除)，因此确保其中没有任何重要的内容。

Dim ws As String
Dim lr As Long, lngMatch As Long, lngEnd As Long, lngStart As Long
Dim rngCell As Range
Dim MatchFormula As String, EndFormula As String, StartFormula As String

ws = ActiveSheet.Name

With Sheets(ws)
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("D2:D" & lr).FormulaR1C1 = _
        "=IF(RC[-3]<>R[-1]C[-3],""s"",IF(AND(RC[-3]=R[-1]C[-3],RC[-3]=R[1]C[-3]),""m"",""e""))"
    For Each rngCell In .Range("B1:B" & lr)
        If Len(rngCell) = 0 Then
            If rngCell.Offset(0, -1).Value = rngCell.Offset(-1, -1).Value _
                Or rngCell.Offset(0, -1).Value = rngCell.Offset(1, -1).Value Then
                On Error Resume Next
                    StartFormula = "LOOKUP(2,1/($D$2:D" & rngCell.Row & "=""s""),ROW($D$2:D" & rngCell.Row & "))"
                    lngStart = Evaluate(StartFormula)
                    EndFormula = "MATCH(""e"",D" & rngCell.Row + 1 & ":$D$" & lr & ",0)"
                    lngEnd = Evaluate(EndFormula)
                    MatchFormula = "MATCH(1,($A$" & lngStart & ":$A$" & lngEnd + rngCell.Row & "=A" & rngCell.Row _
                        & ")*($C$" & lngStart & ":$C$" & lngEnd + rngCell.Row & "=1),0)"
                    lngMatch = Evaluate(MatchFormula)
                On Error GoTo 0
                If lngMatch Then
                    rngCell.Value = .Range("B" & lngStart + lngMatch - 1).Value
                End If
                lngEnd = 0
                lngMatch = 0
            End If
        End If
    Next rngCell
    .Range("D2:D" & lr).Clear
End With

结果：

​

​