增加辅助列(删除重复段落/题目)

2324

非常感谢以上各位大佬的解答，问题已经得到完美解决！再次表示感谢！
结帖

tarim19738

Sub test()
Dim arr, brr, i%, endrow%
endrow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim brr(1 To endrow, 1 To 2)
Range("e1:f" & endrow).Delete
arr = Range("a1").CurrentRegion
brr(1, 1) = "户主"
brr(1, 2) = "名称"
Range("e1:f1").Interior.Color = Range("a1").Interior.Color

For i = 2 To endrow
   If InStr(arr(i, 1), "户主：") Then
      xm = arr(i, 1)
      Range("f" & i).Interior.Color = Range("a2").Interior.Color
      brr(i, 1) = xm
      brr(i, 2) = arr(i, 1)
      Else
      brr(i, 1) = xm
      brr(i, 2) = arr(i, 1)
   
   End If
   
Next
[e1].Resize(endrow, 2) = brr

End Sub

jjmysjg

无关岁月 发表于 2024-3-22 16:38

下列加名，不跟随